[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Mon Jan 14 18:42:43 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv4573/Drei
Modified Files:
drei-redisplay.lisp
Log Message:
Baseline-adjusted drawing for Drei. Please test.
Is very slightly slower than it used to be, but enables an
optimisation (reduction in number of distinct calls to
draw-rectangle*) that I'll finish up shortly.
--- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 12:43:05 1.26
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 18:42:43 1.27
@@ -100,11 +100,12 @@
(style nil))
(defconstant +default-stroke-drawer-dispatcher+
- #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn)
- (funcall default-drawing-fn stream view stroke cursor-x cursor-y))
- "A simple function of six arguments that simply calls the first
-argument as a function with the remaining five arguments. Used as
-the default drawing-function of `drawing-options' objects.")
+ #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn draw)
+ (funcall default-drawing-fn stream view stroke cursor-x cursor-y draw))
+ "A simple function of seven arguments that simply calls the
+first argument as a function with the remaining sex
+arguments. Used as the default drawing-function of
+`drawing-options' objects.")
(defstruct drawing-options
"A set of options for how to display a stroke."
@@ -142,7 +143,7 @@
be absolute coordinates in the coordinate system of a sheet. A
special `center' slot is also provided to enable the recording of
what might be considered a *logical* centre of the dimensions on
-the vertical axis."
+the vertical axis. `Center' should be relative to `y1'."
(x1 0)
(y1 0)
(x2 0)
@@ -189,6 +190,13 @@
(widths)
(parts))
+(defun stroke-at-end-of-line (buffer stroke)
+ "Return true if the end offset of `stroke' is at the end of a
+line in `buffer'. Otherwise, return nil. The end offset of
+`stroke' must be a valid offset for `buffer' or an error will be
+signalled."
+ (offset-end-of-line-p buffer (stroke-end-offset stroke)))
+
(defstruct (displayed-line (:conc-name line-))
"A line on display. A line delimits a buffer region (always
bounded by newline objects or border beginning/end) and contains
@@ -391,8 +399,7 @@
sets the modified-bit of `stroke' to false, as it updates the
dimensions."
(let ((dimensions (stroke-dimensions stroke)))
- (setf (stroke-dirty stroke) (and (stroke-dirty stroke)
- (not drawn))
+ (setf (stroke-dirty stroke) (and (stroke-dirty stroke) (not drawn))
(stroke-modified stroke) nil
(stroke-parts stroke) parts
(stroke-widths stroke) widths
@@ -443,12 +450,11 @@
"Calculate the width information of `stroke-string' when
displayed with `text-style' (which must be fully specified) on
`stream', starting at the horizontal device unit offset
-`x-position'. Four values will be returned: the total width of
-the stroke, the baseline, the parts of the stroke and the widths
-of the parts of the stroke."
+`x-position'. Three values will be returned: the total width of
+the stroke, the parts of the stroke and the widths of the parts
+of the stroke."
(loop with parts = (analyse-stroke-string stroke-string)
with width = 0
- with baseline = 0
with widths = (make-array (length parts) :adjustable t :fill-pointer t)
with tab-width
for (start end object) in parts
@@ -459,32 +465,32 @@
(mod (+ width x-position) tab-width)))
(vector-push-extend width widths))
(object
- (multiple-value-bind (w ignore1 ignore2 ignore3 b)
+ (multiple-value-bind (w ignore1 ignore2 ignore3 ignore4)
(text-size stream object
:text-style text-style)
- (declare (ignore ignore1 ignore2 ignore3))
+ (declare (ignore ignore1 ignore2 ignore3 ignore4))
(incf width w)
- (setf baseline (max baseline b))
(vector-push-extend width widths)))
(t
- (multiple-value-bind (w ignore1 ignore2 ignore3 b)
+ (multiple-value-bind (w ignore1 ignore2 ignore3 ignore4)
(text-size stream stroke-string
:start start :end end
:text-style text-style)
- (declare (ignore ignore1 ignore2 ignore3))
+ (declare (ignore ignore1 ignore2 ignore3 ignore4))
(incf width w)
- (setf baseline (max baseline b))
(vector-push-extend width widths))))
- finally (return (values width baseline parts widths))))
+ finally (return (values width parts widths))))
-(defun stroke-drawing-fn (stream view stroke cursor-x cursor-y)
- "Draw `stroke' to `stream' at the position (`cursor-x',
+(defun stroke-drawing-fn (stream view stroke cursor-x cursor-y draw)
+ "Draw `stroke' to `stream' baseline-adjusted at the position (`cursor-x',
`cursor-y'). `View' is the view object that `stroke' belongs
-to. It is assumed that the buffer region delimited by `stroke'
-only contains characters. `Stroke' is drawn with face given by
-the drawing options of `stroke', using the default text style of
-`stream' to fill out any holes. The screen area beneath `stroke'
-will be cleared before any actual output takes place."
+to. If `draw' is true, actually draw the stroke to `stream',
+otherwise, just calculate its size. It is assumed that the buffer
+region delimited by `stroke' only contains characters. `Stroke'
+is drawn with face given by the drawing options of `stroke',
+using the default text style of `stream' to fill out any
+holes. The screen area beneath `stroke' will be cleared before
+any actual output takes place."
(with-accessors ((start-offset stroke-start-offset)
(end-offset stroke-end-offset)
(dimensions stroke-dimensions)
@@ -500,56 +506,56 @@
;; Ignore face when computing height, otherwise we get
;; bouncy lines when things like parenmatching bolds parts
;; of the line.
- (roman-text-style (merge-text-styles +roman-face-style+
- merged-text-style))
+ (roman-text-style (merge-text-styles +roman-face-style+ merged-text-style))
(text-style-ascent (text-style-ascent roman-text-style (sheet-medium stream)))
- (text-style-descent (text-style-descent roman-text-style (sheet-medium stream)))
- (text-style-height (+ text-style-ascent text-style-descent)))
+ (text-style-descent (text-style-descent roman-text-style (sheet-medium stream))))
(with-accessors ((x1 x1) (x2 x2) (center center)) dimensions
- (multiple-value-bind (width baseline stroke-parts part-widths)
+ (multiple-value-bind (width stroke-parts part-widths)
(if (stroke-modified stroke)
(calculate-stroke-width stroke-string merged-text-style stream cursor-x)
- (values (- x2 x1) center parts widths))
- (clear-rectangle* stream cursor-x cursor-y
- (+ cursor-x width) (+ cursor-y text-style-height
- (stream-vertical-spacing stream)))
- (loop for (start end object) in stroke-parts
- for width across part-widths
- do (cond ((and object (eq object #\Tab))
- nil)
- (object
- (draw-text* stream object (+ cursor-x width)
- (+ cursor-y
- (- text-style-ascent
- baseline))
- :text-style merged-text-style
- :ink +darkblue+
- :align-y :top))
- (t
- (draw-text* stream stroke-string (+ cursor-x width)
- (+ cursor-y
- (- text-style-ascent
- baseline))
- :start start :end end
- :text-style merged-text-style
- :ink (face-ink (drawing-options-face drawing-options))
- :align-y :top))))
- (record-stroke stroke stroke-parts part-widths cursor-x cursor-y
- (+ width cursor-x) (+ text-style-height cursor-y)
- t baseline))))))
+ (values (- x2 x1) parts widths))
+ (when draw
+ (loop for (start end object) in stroke-parts
+ for width across part-widths
+ do (cond ((and object (eq object #\Tab))
+ nil)
+ (object
+ (draw-text* stream object (+ cursor-x width)
+ cursor-y
+ :text-style merged-text-style
+ :ink +darkblue+
+ :align-y :baseline))
+ (t
+ (draw-text* stream stroke-string (+ cursor-x width)
+ cursor-y
+ :start start :end end
+ :text-style merged-text-style
+ :ink (face-ink (drawing-options-face drawing-options))
+ :align-y :baseline)))))
+ (record-stroke stroke stroke-parts part-widths
+ cursor-x (- cursor-y text-style-ascent)
+ (+ width cursor-x) (+ cursor-y text-style-descent)
+ draw text-style-ascent))))))
+
+(defun update-stroke-dimensions (stream view stroke cursor-x cursor-y)
+ "Calculate the dimensions of `stroke' on `stream'
+at (`cursor-x', `cursor-y'), but without actually drawing
+anything. Will use the function specified in the drawing-options
+of `stroke' to carry out the actual calculations."
+ (unless (= cursor-x (x1 (stroke-dimensions stroke)))
+ (invalidate-stroke stroke :modified t))
+ (when (stroke-dirty stroke)
+ (funcall (drawing-options-function (stroke-drawing-options stroke)) stream view stroke
+ cursor-x cursor-y #'stroke-drawing-fn nil)))
(defun draw-stroke (stream view stroke cursor-x cursor-y)
- "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing
-will be done unless `stroke' is dirty. Will use the function
-specified in the drawing-options of `stroke' to carry out the
-actual drawing."
- (let* ((drawing-options (stroke-drawing-options stroke)))
- (unless (and (= cursor-x (x1 (stroke-dimensions stroke)))
- (= cursor-y (y1 (stroke-dimensions stroke))))
- (invalidate-stroke stroke :modified t))
- (when (stroke-dirty stroke)
- (funcall (drawing-options-function drawing-options) stream view stroke
- cursor-x cursor-y #'stroke-drawing-fn))))
+ "Draw `stroke' on `stream' with a baseline at
+`cursor-y'. Drawing starts at the horizontal offset
+`cursor-x'. Stroke must thus have updated dimensional
+informational. Nothing will be done unless `stroke' is dirty."
+ (when (stroke-dirty stroke)
+ (funcall (drawing-options-function (stroke-drawing-options stroke))
+ stream view stroke cursor-x cursor-y #'stroke-drawing-fn t)))
(defun end-line (line x1 y1 line-width line-height)
"End the addition of strokes to `line' for now, and update the
@@ -568,21 +574,20 @@
associated dimensions. Also clear from the bottom of strokes to
the bottom of the line, and from the end of the line to the end
of the sheet."
+ (declare (ignore old-line-width))
(end-line line line-x1 line-y1 line-width line-height)
(with-accessors ((line-x1 x1) (line-y1 y1)
(line-x2 x2) (line-y2 y2)) (line-dimensions line)
- ;; If a has a lesser height than the line, clear from the bottom
- ;; of the stroke to the bottom of the line, to avoid artifacts
- ;; left over from prefvious redisplays.
+ ;; If a has a lesser height than the line, clear from the top of
+ ;; the line stroke to the top of the stroke, to avoid artifacts
+ ;; left over from previous redisplays.
(do-displayed-line-strokes (stroke line)
(let ((stroke-dimensions (stroke-dimensions stroke)))
(with-accessors ((stroke-x1 x1) (stroke-y1 y1)
(stroke-x2 x2) (stroke-y2 y2)) stroke-dimensions
(when (> line-height (dimensions-height stroke-dimensions))
- (clear-rectangle* stream stroke-x1 stroke-y2
- stroke-x2 (+ stroke-y2 (- line-height
- (dimensions-height stroke-dimensions))
- (stream-vertical-spacing stream)))))))
+ (clear-rectangle* stream stroke-x1 line-y1
+ stroke-x2 stroke-y1)))))
;; Reset the dimensions of undisplayed lines.
(do-undisplayed-line-strokes (stroke line)
(let ((stroke-dimensions (stroke-dimensions stroke)))
@@ -594,43 +599,58 @@
(clear-rectangle* stream line-x2 line-y1
(bounding-rectangle-width stream)
(+ line-y1 (max line-height old-line-height)
- (stream-vertical-spacing stream)))
- (when (or (> old-line-height line-height)
- (> old-line-width line-width))
- (clear-rectangle* stream line-x1 (+ line-y1 line-height)
- (+ line-x1 (max old-line-width line-width))
- (+ line-y1 (max old-line-height line-height))))))
+ (stream-vertical-spacing stream)))))
(defun draw-line-strokes (stream view initial-pump-state
start-offset cursor-x cursor-y)
"Pump strokes from `view', using `initial-pump-state' to begin
with, and draw them on `stream'. The line is set to start at the
buffer offset `start-offset', and will be drawn starting
-at (`cursor-x', `cursor-y')"
+at (`cursor-x', `cursor-y')."
(let* ((line (line-information view (displayed-lines-count view)))
(old-line-height (dimensions-height (line-dimensions line)))
(old-line-width (dimensions-width (line-dimensions line)))
(orig-x-offset cursor-x)
- (offset-change (- start-offset (line-start-offset line))))
+ (offset-change (- start-offset (line-start-offset line)))
+ (line-spacing (stream-vertical-spacing stream)))
(setf (line-start-offset line) start-offset
(line-stroke-count line) 0)
- (loop for index from 0
- for stroke = (line-stroke-information line index)
- for stroke-dimensions = (stroke-dimensions stroke)
- for pump-state = (put-stroke view line initial-pump-state offset-change) then
- (put-stroke view line pump-state offset-change)
- do (draw-stroke stream view stroke cursor-x cursor-y)
- (setf cursor-x (x2 stroke-dimensions))
- maximizing (dimensions-height stroke-dimensions) into line-height
- summing (- (x2 stroke-dimensions)
- (x1 stroke-dimensions)) into line-width
- when (or (= (stroke-end-offset stroke) (size (buffer view)))
- (eql (buffer-object (buffer view) (stroke-end-offset stroke)) #\Newline))
- return (progn (end-line-cleaning-up stream line orig-x-offset cursor-y
- line-width old-line-width
- line-height old-line-height)
- (incf (displayed-lines-count view))
- (values pump-state line-height)))))
+ ;; So yeah, this is fairly black magic, but it's not actually
+ ;; ugly, just complex.
+ (multiple-value-bind (line-width line-height baseline pump-state)
+ ;; Pump all the line strokes and calculate their dimensions.
+ (loop for index from 0
+ for stroke = (line-stroke-information line index)
+ for stroke-dimensions = (stroke-dimensions stroke)
+ for pump-state = (put-stroke view line initial-pump-state offset-change) then
+ (put-stroke view line pump-state offset-change)
+ do (update-stroke-dimensions stream view stroke cursor-x cursor-y)
+ (setf cursor-x (x2 stroke-dimensions))
+ maximizing (dimensions-height stroke-dimensions) into line-height
+ maximizing (+ (center stroke-dimensions) cursor-y) into baseline
+ summing (dimensions-width stroke-dimensions) into line-width
+ when (stroke-at-end-of-line (buffer view) stroke)
+ return (values line-width line-height baseline pump-state))
+ ;; Now actually draw them in a way that makes sure they all
+ ;; touch the bottom of the line.
+ (loop with last-clear-x = orig-x-offset
+ for stroke-index below (line-stroke-count line)
+ for stroke = (aref (line-strokes line) stroke-index)
+ for stroke-dimensions = (stroke-dimensions stroke)
+ do (unless (= baseline (+ cursor-y (center stroke-dimensions)))
+ (invalidate-stroke stroke))
+ (when (stroke-dirty stroke)
+ (clear-rectangle* stream (x1 stroke-dimensions) cursor-y
+ (x2 stroke-dimensions)
+ (+ cursor-y line-height line-spacing))
+ (setf last-clear-x (x2 stroke-dimensions)))
+ (draw-stroke stream view stroke
+ (x1 stroke-dimensions) baseline)
+ finally (progn (end-line-cleaning-up stream line orig-x-offset cursor-y
+ line-width old-line-width
+ line-height old-line-height)
+ (incf (displayed-lines-count view))
+ (return (values pump-state line-height)))))))
(defun clear-stale-lines (pane view)
"Clear from the last displayed line to the end of `pane'."
@@ -652,7 +672,7 @@
(widths (make-array 2 :initial-contents (list 0 0)))
(parts (list 0 1)))
#'(lambda (stream view stroke cursor-x cursor-y
- default-drawing-fn)
+ default-drawing-fn draw)
(declare (ignore default-drawing-fn))
(with-accessors ((start-offset stroke-start-offset)
(drawing-options stroke-drawing-options)) stroke
@@ -665,20 +685,17 @@
;; like the changing position is ignored. So add some
;; minuscule amount to it, and all will be well. 0.1
;; device units shouldn't even be visible.
- (setf (output-record-position output-record) (values (+ cursor-x 0.1) cursor-y))
(let ((width (bounding-rectangle-width output-record))
(height (bounding-rectangle-height output-record)))
- (clear-rectangle* stream cursor-x cursor-y
- (+ cursor-x width) (+ cursor-y height
- (stream-vertical-spacing stream)))
- (replay output-record stream)
+ (setf (output-record-position output-record)
+ (values (+ cursor-x 0.1) (- cursor-y height)))
+ (when draw
+ (replay output-record stream))
(setf (aref widths 1) width)
(record-stroke stroke parts widths
- cursor-x cursor-y (+ width cursor-x)
- (+ (if (zerop height)
- (text-style-height (medium-text-style stream) stream)
- height)
- cursor-y))))))))
+ cursor-x (- cursor-y height)
+ (+ width cursor-x) cursor-y
+ draw height)))))))
(defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer))
"For a `drei-buffer-view' a pump-state is merely an offset into
@@ -767,7 +784,7 @@
(defgeneric offset-to-screen-position (pane view offset)
(:documentation "Returns the position of offset as a screen
-position. Returns `x', `y', `line-height', `OBJECT-WIDTH' as
+position. Returns `x', `y', `stroke-height', `object-width' as
values if offset is on the screen, NIL if offset is before the
beginning of the screen, and T if offset is after the end of the
screen. `Object-width' may be an approximation if `offset' is at
@@ -786,7 +803,7 @@
(/= start-offset end-offset))
(return-from worker
(values (x1 stroke-dimensions) (y1 stroke-dimensions)
- (dimensions-height line-dimensions)
+ (dimensions-height stroke-dimensions)
(if (= end-offset (1+ start-offset))
(dimensions-width stroke-dimensions)
(offset-in-stroke-position pane view stroke (1+ offset))))))
@@ -796,7 +813,7 @@
(let* ((relative-x-position (offset-in-stroke-position pane view stroke offset))
(absolute-x-position (+ (x1 stroke-dimensions) relative-x-position)))
(values absolute-x-position (y1 stroke-dimensions)
- (dimensions-height line-dimensions)
+ (dimensions-height stroke-dimensions)
(if (= (1+ offset) end-offset)
(- (x2 stroke-dimensions) absolute-x-position)
(- (offset-in-stroke-position pane view stroke (1+ offset))
@@ -815,9 +832,9 @@
;; Search through strokes, returning when we find one that
;; `offset' is in. Strokes with >1 object are assumed to be
;; strings.
- (multiple-value-bind (x y line-height object-width) (worker)
- (if (and x y line-height)
- (values x y line-height (or object-width default-object-width))
[21 lines skipped]
More information about the Mcclim-cvs
mailing list