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)))) ,@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)))))