[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Wed Feb 13 21:58:50 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv15222/Drei
Modified Files:
drei-redisplay.lisp views.lisp
Log Message:
Some general cleanups in Drei redisplay.
No functionality changes.
--- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/12 19:22:37 1.63
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/13 21:58:50 1.64
@@ -272,37 +272,6 @@
do (invalidate-line-strokes line
:modified modified :cleared cleared)))
-(defun invalidate-strokes-in-region (view start-offset end-offset
- &key modified cleared)
- "Invalidate all the strokes of `view' that overlap the region
-`start-offset'/`end-offset' by setting their dirty-bit to
-true. If `modified' or `cleared' is true, also set their
-modified-bit to true. If `cleared' is true, inform the strokes
-that their previous output has been cleared by someone, and that
-they do not need to clear it themselves during their next
-redisplay."
- ;; If the region is outside the visible region, no-op.
- (when (overlaps start-offset end-offset
- (offset (top view)) (offset (bot view)))
- (let ((line1-index (index-of-displayed-line-containing-offset view start-offset))
- (line2-index (index-of-displayed-line-containing-offset view end-offset)))
- (loop for line = (line-information view line1-index)
- when (<= start-offset
- (line-start-offset line) (line-end-offset line)
- end-offset)
- ;; The entire line is within the region.
- do (invalidate-line-strokes line :modified modified
- :cleared cleared)
- ;; Only part of the line is within the region.
- else do (do-displayed-line-strokes (stroke line)
- (when (overlaps start-offset end-offset
- (stroke-start-offset stroke)
- (stroke-end-offset stroke))
- (invalidate-stroke stroke :modified modified
- :cleared cleared)))
- if (= line1-index line2-index) do (loop-finish)
- else do (incf line1-index)))))
-
(defmacro do-displayed-lines ((line-sym view) &body body)
"Loop over lines on display for `view', evaluating `body' with
`line-sym' bound to the `displayed-line' object for each line."
@@ -348,6 +317,39 @@
(+ (line-stroke-count ,line) ,stroke-index))))
, at body)))))
+(defun invalidate-strokes-in-region (view start-offset end-offset
+ &key modified cleared)
+ "Invalidate all the strokes of `view' that overlap the region
+`start-offset'/`end-offset' by setting their dirty-bit to
+true. If `modified' or `cleared' is true, also set their
+modified-bit to true. If `cleared' is true, inform the strokes
+that their previous output has been cleared by someone, and that
+they do not need to clear it themselves during their next
+redisplay."
+ (as-region (start-offset end-offset)
+ ;; If the region is outside the visible region, no-op.
+ (when (and (plusp (displayed-lines-count view)) ; If there is any display...
+ (overlaps start-offset end-offset
+ (offset (top view)) (offset (bot view))))
+ (let ((line1-index (index-of-displayed-line-containing-offset view start-offset))
+ (line2-index (index-of-displayed-line-containing-offset view end-offset)))
+ (loop for line = (line-information view line1-index)
+ when (<= start-offset
+ (line-start-offset line) (line-end-offset line)
+ end-offset)
+ ;; The entire line is within the region.
+ do (invalidate-line-strokes line :modified modified
+ :cleared cleared)
+ ;; Only part of the line is within the region.
+ else do (do-displayed-line-strokes (stroke line)
+ (when (overlaps start-offset end-offset
+ (stroke-start-offset stroke)
+ (stroke-end-offset stroke))
+ (invalidate-stroke stroke :modified modified
+ :cleared cleared)))
+ if (= line1-index line2-index) do (loop-finish)
+ else do (incf line1-index))))))
+
(defun find-stroke-containing-offset (view offset)
"Find the stroke of `view' that displays the buffer offset
`offset'. If no such stroke can be found, this function returns
@@ -430,7 +432,8 @@
`view', and add it to the sequence of displayed strokes in
`line'. `Line-change' should be a relative offset specifying how
much the start-offset of `line' has changed since the last time
-it was redisplayed."
+it was redisplayed. `Offset' is the offset at which the next
+stroke will start."
(let* ((stroke (line-stroke-information line (line-stroke-count line)))
(old-start-offset (stroke-start-offset stroke))
(old-end-offset (stroke-end-offset stroke))
@@ -678,19 +681,21 @@
;; ugly, just complex.
(multiple-value-bind (line-width baseline descent 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 pane view stroke cursor-x cursor-y)
- (setf cursor-x (x2 stroke-dimensions))
- maximizing (- (dimensions-height stroke-dimensions)
- (center stroke-dimensions)) into descent
- 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 baseline descent pump-state))
+ (loop with offset = start-offset
+ 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 pane view stroke cursor-x cursor-y)
+ (setf cursor-x (x2 stroke-dimensions))
+ (setf offset (stroke-end-offset stroke))
+ maximizing (- (dimensions-height stroke-dimensions)
+ (center stroke-dimensions)) into descent
+ 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 baseline descent pump-state))
(let ((line-height (- (+ baseline descent) cursor-y)))
;; Loop over the strokes and clear the parts of the pane that
;; has to be redrawn, trying to minimise the number of calls to
@@ -783,16 +788,19 @@
(defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view))
(with-bounding-rectangle* (x1 y1 x2 y2) view
- (let ((old-width (- x2 x1))
- (old-height (- y2 y1)))
+ (let* ((old-width (- x2 x1))
+ (old-height (- y2 y1))
+ (start-offset (offset (beginning-of-line (top view))))
+ (pump-state (pump-state-for-offset view start-offset))
+ (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane))))
+ ;; For invalidation of the parts of the display that have
+ ;; changed.
+ (synchronize-view view :begin (offset (top view)) :end (offset (bot view)))
(setf (displayed-lines-count view) 0
(max-line-width view) 0)
(multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane)
(with-output-recording-options (pane :record nil :draw t)
- (loop with start-offset = (offset (beginning-of-line (top view)))
- with pump-state = (pump-state-for-offset view start-offset)
- with pane-height = (bounding-rectangle-height (or (pane-viewport pane) pane))
- for line = (line-information view (displayed-lines-count view))
+ (loop for line = (line-information view (displayed-lines-count view))
do (multiple-value-bind (new-pump-state line-height)
(draw-line-strokes pane view pump-state start-offset
cursor-x cursor-y old-width)
@@ -823,17 +831,19 @@
"Return a pump state usable for pumpting strokes for `view' (a
`drei-buffer-view') from `offset'."
;; Perform binary search looking for line starting with `offset'.
+ (synchronize-view view :begin offset)
(with-accessors ((lines lines)) view
(loop with low-index = 0
with high-index = (nb-elements lines)
for middle = (floor (+ low-index high-index) 2)
- for line-start = (start-mark (element* lines middle))
- do (cond ((mark> offset line-start)
+ for this-line = (element* lines middle)
+ for line-start = (start-mark this-line)
+ do (cond ((offset-in-line-p this-line offset)
+ (loop-finish))
+ ((mark> offset line-start)
(setf low-index (1+ middle)))
((mark< offset line-start)
- (setf high-index middle))
- ((mark= offset line-start)
- (loop-finish)))
+ (setf high-index middle)))
finally (return (make-pump-state middle offset 0)))))
(defun fetch-chunk (line chunk-index)
--- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/12 19:22:37 1.36
+++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/13 21:58:50 1.37
@@ -578,7 +578,7 @@
the string is accessed through the reader.")
(%displayed-lines :accessor displayed-lines
:initform (make-array 0 :element-type 'displayed-line
- :initial-element (make-displayed-line))
+ :initial-element (make-displayed-line))
:type array
:documentation "An array of the
`displayed-line' objects displayed by the view. Not all of these
@@ -594,10 +594,18 @@
:type number
:documentation "The width of the longest
displayed line in device units.")
- (lines :initform (make-instance 'standard-flexichain)
- :reader lines
- :documentation "The lines of the buffer, stored in a
-format that makes it easy to retrieve information about them."))
+ (%lines :initform (make-instance 'standard-flexichain)
+ :reader lines
+ :documentation "The lines of the buffer, stored in a
+format that makes it easy to retrieve information about them.")
+ (%lines-prefix :accessor lines-prefix-size
+ :documentation "The number of unchanged
+objects at the start of the buffer since the list of lines was
+last updated.")
+ (%lines-suffix :accessor lines-suffix-size
+ :documentation "The number of unchanged objects
+at the end of the buffer since since the list of lines was last
+updated."))
(:metaclass modual-class)
(:documentation "A view that contains a `drei-buffer'
object. The buffer is displayed on a simple line-by-line basis,
@@ -608,7 +616,9 @@
&key buffer single-line read-only
initial-contents)
(declare (ignore initargs))
- (with-accessors ((top top) (bot bot)) view
+ (with-accessors ((top top) (bot bot)
+ (lines-prefix lines-prefix-size)
+ (lines-suffix lines-suffix-size)) view
(unless buffer
;; So many fun things are defined on (setf buffer) that we use
;; slot-value here. This is just a glorified initform anyway.
@@ -617,8 +627,9 @@
:read-only read-only
:initial-contents initial-contents)))
(setf top (make-buffer-mark (buffer view) 0 :left)
- bot (make-buffer-mark (buffer view) (size (buffer view)) :right))
- (update-line-data view 0 (size (buffer view)))))
+ bot (clone-mark top :right)
+ lines-prefix 0
+ lines-suffix 0)))
(defmethod (setf top) :after (new-value (view drei-buffer-view))
(invalidate-all-strokes view))
@@ -628,12 +639,13 @@
(defmethod (setf buffer) :after (buffer (view drei-buffer-view))
(invalidate-all-strokes view)
- (with-accessors ((top top) (bot bot)) view
- (setf top (make-buffer-mark buffer 0 :left)
- bot (make-buffer-mark buffer (size buffer) :right))))
-
-(defmethod (setf syntax) :after (new-value (view drei-buffer-view))
- (invalidate-all-strokes view :modified t))
+ (with-accessors ((top top) (bot bot)
+ (lines-prefix lines-prefix-size)
+ (lines-suffix lines-suffix-size)) view
+ (setf top (make-buffer-mark buffer 0 :left)
+ bot (clone-mark top :right)
+ lines-prefix 0
+ lines-suffix 0)))
(defmethod cache-string :around ((view drei-buffer-view))
(let ((string (call-next-method)))
@@ -713,55 +725,59 @@
(cons (- (1+ chunk-end-offset)
line-start-offset) t)))))
-(defun update-line-data (view start end)
+(defun update-line-data (view)
"Update the sequence of lines stored by the `drei-buffer-view'
-`view'. `Start' and `end' are buffer offsets delimiting the
-region that has changed since the last update."
- (let ((low-mark (make-buffer-mark (buffer view) start :left))
- (high-mark (make-buffer-mark (buffer view) end :left)))
- (when (mark<= low-mark high-mark)
- (beginning-of-line low-mark)
- (end-of-line high-mark)
- (with-accessors ((lines lines)) view
- (let ((low-index 0)
- (high-index (nb-elements lines)))
- ;; Binary search for the start of changed lines.
- (loop while (< low-index high-index)
- do (let* ((middle (floor (+ low-index high-index) 2))
- (line-start (start-mark (element* lines middle))))
- (cond ((mark> low-mark line-start)
- (setf low-index (1+ middle)))
- (t
- (setf high-index middle)))))
- ;; Discard lines that have to be re-analyzed.
- (loop while (and (< low-index (nb-elements lines))
- (mark<= (start-mark (element* lines low-index))
- high-mark))
- do (delete* lines low-index))
- ;; Analyze new lines.
- (loop while (mark<= low-mark high-mark)
- for i from low-index
- do (progn (let ((line-start-mark (clone-mark low-mark)))
- (insert* lines i (make-instance
- 'buffer-line
- :start-mark line-start-mark
- :line-length (- (offset (end-of-line low-mark))
- (offset line-start-mark))))
- (if (end-of-buffer-p low-mark)
- (loop-finish)
- ;; skip newline
- (forward-object low-mark))))))))))
+`view'."
+ (with-accessors ((prefix-size lines-prefix-size)
+ (suffix-size lines-suffix-size)) view
+ (when (<= prefix-size (- (size (buffer view)) suffix-size))
+ (let ((low-mark (make-buffer-mark (buffer view) prefix-size :left))
+ (high-mark (make-buffer-mark
+ (buffer view) (- (size (buffer view)) suffix-size) :left)))
+ (beginning-of-line low-mark)
+ (end-of-line high-mark)
+ (with-accessors ((lines lines)) view
+ (let ((low-index 0)
+ (high-index (nb-elements lines)))
+ ;; Binary search for the start of changed lines.
+ (loop while (< low-index high-index)
+ do (let* ((middle (floor (+ low-index high-index) 2))
+ (line-start (start-mark (element* lines middle))))
+ (cond ((mark> low-mark line-start)
+ (setf low-index (1+ middle)))
+ (t
+ (setf high-index middle)))))
+ ;; Discard lines that have to be re-analyzed.
+ (loop while (and (< low-index (nb-elements lines))
+ (mark<= (start-mark (element* lines low-index))
+ high-mark))
+ do (delete* lines low-index))
+ ;; Analyze new lines.
+ (loop while (mark<= low-mark high-mark)
+ for i from low-index
+ do (progn (let ((line-start-mark (clone-mark low-mark)))
+ (insert* lines i (make-instance
+ 'buffer-line
+ :start-mark line-start-mark
+ :line-length (- (offset (end-of-line low-mark))
+ (offset line-start-mark))))
+ (if (end-of-buffer-p low-mark)
+ (loop-finish)
+ ;; skip newline
+ (forward-object low-mark)))))))))
+ (setf prefix-size (size (buffer view))
+ suffix-size (size (buffer view)))))
(defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer)
changed-region)
(destructuring-bind (start-offset . end-offset) changed-region
- ;; If something has been redisplayed, and there have been changes
- ;; to some of those strokes, mark them as dirty.
- (invalidate-strokes-in-region
- view start-offset end-offset :modified t)
- ;; I suspect it's most efficient to keep this always up to date,
- ;; even for small changes.
- (update-line-data view start-offset end-offset)))
+ (with-accessors ((prefix-size lines-prefix-size)
+ (suffix-size lines-suffix-size)) view
+ (setf prefix-size (min start-offset prefix-size)
+ suffix-size (min (- (size buffer) end-offset) suffix-size)))))
+
+(defmethod synchronize-view ((view drei-buffer-view) &key)
+ (update-line-data view))
;;; Exploit the stored line information.
@@ -771,24 +787,32 @@
(<= (offset (start-mark line)) offset
(end-offset line)))
+(defun index-of-line-containing-offset (view mark-or-offset)
+ "Return the index of the line `mark-or-offset' is in for
+`view'. `View' must be a `drei-buffer-view'."
+ ;; Perform binary search looking for line containing `offset1'.
+ (as-offsets ((offset mark-or-offset))
+ (with-accessors ((lines lines)) view
+ (loop with low-index = 0
+ with high-index = (nb-elements lines)
+ for middle = (floor (+ low-index high-index) 2)
+ for this-line = (element* lines middle)
+ for line-start = (start-mark this-line)
+ do (cond ((offset-in-line-p this-line offset)
+ (loop-finish))
+ ((mark> offset line-start)
+ (setf low-index (1+ middle)))
+ ((mark< offset line-start)
+ (setf high-index middle)))
+ finally (return middle)))))
+
(defun line-containing-offset (view mark-or-offset)
"Return the line `mark-or-offset' is in for `view'. `View'
must be a `drei-buffer-view'."
;; Perform binary search looking for line containing `offset1'.
(as-offsets ((offset mark-or-offset))
(with-accessors ((lines lines)) view
- (loop with low-index = 0
- with high-index = (nb-elements lines)
- for middle = (floor (+ low-index high-index) 2)
- for this-line = (element* lines middle)
- for line-start = (start-mark this-line)
- do (cond ((offset-in-line-p this-line offset)
- (loop-finish))
- ((mark> offset line-start)
- (setf low-index (1+ middle)))
- ((mark< offset line-start)
- (setf high-index middle)))
- finally (return this-line)))))
+ (element* lines (index-of-line-containing-offset view offset)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -838,11 +862,7 @@
(add-observer buffer view)
;; We need a new syntax object of the same type as the old one, and
;; to zero out the unchanged-prefix-values.
- (with-accessors ((view-syntax syntax)
- (suffix-size suffix-size)
- (prefix-size prefix-size)
- (buffer-size buffer-size)
- (bot bot) (top top)) view
+ (with-accessors ((view-syntax syntax)) view
(setf view-syntax (make-syntax-for-view view (class-of view-syntax)))))
(defmethod (setf syntax) :after (syntax (view drei-syntax-view))
@@ -869,17 +889,18 @@
(defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer)
changed-region)
- (with-accessors ((prefix-size prefix-size)
- (suffix-size suffix-size)) view
- (setf prefix-size (min (car changed-region) prefix-size)
- suffix-size (min (- (size buffer) (cdr changed-region))
- suffix-size)
- (modified-p view) t))
+ (destructuring-bind (start-offset . end-offset) changed-region
+ (with-accessors ((prefix-size prefix-size)
+ (suffix-size suffix-size)
+ (modified-p modified-p)) view
+ (setf prefix-size (min start-offset prefix-size)
+ suffix-size (min (- (size buffer) end-offset) suffix-size)
+ modified-p t)))
(call-next-method))
(defun needs-resynchronization (view)
"Return true if the the view of the buffer of `view' is
-potentially out of date. Return false otherwise."
+potentially out of date. Return false otherwise."
(not (= (prefix-size view) (suffix-size view)
(buffer-size view) (size (buffer view)))))
More information about the Mcclim-cvs
mailing list