[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Tue Jan 1 18:43:36 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv13721/Drei
Modified Files:
buffer.lisp drei-clim.lisp drei-redisplay.lisp packages.lisp
views.lisp
Log Message:
Added new redisplay engine for Drei. Used by default. Does not yet
talk to the syntax, so there is no syntax highlighting, but other
syntax facilities work just fine. It is significantly faster than the
old engine, but not yet Emacs-style fast. It supports variable-width
fonts, lines of varying height (though lines are topline-adjusted at
the moment) and even arbitrary buffer objects with reasonable
performance.
--- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2007/12/08 08:53:50 1.5
+++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/01 18:43:36 1.6
@@ -37,7 +37,8 @@
of the buffer is not necessarily a newline character."))
(defclass standard-buffer (buffer)
- ((contents :initform (make-instance 'standard-cursorchain)))
+ ((contents :initform (make-instance 'standard-cursorchain)
+ :reader contents))
(:documentation "The standard instantiable class for buffers."))
(defgeneric buffer (mark)
@@ -231,7 +232,7 @@
(:documentation "Return the number of objects in the buffer."))
(defmethod size ((buffer standard-buffer))
- (nb-elements (slot-value buffer 'contents)))
+ (nb-elements (contents buffer)))
(defgeneric number-of-lines (buffer)
(:documentation "Return the number of lines of the buffer, or really the number of
@@ -473,7 +474,7 @@
(make-condition 'offset-before-beginning :offset offset))
(assert (<= offset (size buffer)) ()
(make-condition 'offset-after-end :offset offset))
- (insert* (slot-value buffer 'contents) offset object))
+ (insert* (contents buffer) offset object))
(defgeneric insert-buffer-sequence (buffer offset sequence)
(:documentation "Like calling insert-buffer-object on each of
@@ -484,7 +485,7 @@
(make-condition 'offset-before-beginning :offset offset))
(assert (<= offset (size buffer)) ()
(make-condition 'offset-after-end :offset offset))
- (insert-vector* (slot-value buffer 'contents) offset sequence))
+ (insert-vector* (contents buffer) offset sequence))
(defgeneric insert-object (mark object)
(:documentation "Insert the object at the mark. This function
@@ -516,7 +517,7 @@
(assert (<= (+ offset n) (size buffer)) ()
(make-condition 'offset-after-end :offset (+ offset n)))
(loop repeat n
- do (delete* (slot-value buffer 'contents) offset)))
+ do (delete* (contents buffer) offset)))
(defgeneric delete-range (mark &optional n)
(:documentation "Delete `n' objects after `(if n > 0)' or
@@ -566,7 +567,7 @@
(make-condition 'offset-before-beginning :offset offset))
(assert (<= offset (1- (size buffer))) ()
(make-condition 'offset-after-end :offset offset))
- (element* (slot-value buffer 'contents) offset))
+ (element* (contents buffer) offset))
(defgeneric (setf buffer-object) (object buffer offset)
(:documentation "Set the object at the offset in the
@@ -579,7 +580,7 @@
(make-condition 'offset-before-beginning :offset offset))
(assert (<= offset (1- (size buffer))) ()
(make-condition 'offset-after-end :offset offset))
- (setf (element* (slot-value buffer 'contents) offset) object))
+ (setf (element* (contents buffer) offset) object))
(defgeneric buffer-sequence (buffer offset1 offset2)
(:documentation "Return the contents of the buffer starting at
--- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/23 00:40:36 1.25
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/01 18:43:36 1.26
@@ -76,8 +76,8 @@
enabled, it will simply be ignored during redisplay.")
(%active-ink :accessor active-ink
:initarg :active-ink
- :initform +red+
- :type color
+ :initform +flipping-ink+
+ :type design
:documentation "The ink used to draw the cursor
when it is active.")
(%inactive-ink :accessor inactive-ink
@@ -180,6 +180,9 @@
(offset (mark cursor))
(offset (bot view))))
+(defmethod (setf view) :after (new-val (drei drei-pane))
+ (window-clear drei))
+
(defmethod note-sheet-grafted :after ((pane drei-pane))
(setf (stream-default-view pane) (view pane)))
--- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 21:25:12 1.12
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 18:43:36 1.13
@@ -33,16 +33,6 @@
;;;
;;; Display of Drei instances.
;;;
-;;; Syntaxes can customize their redisplay (for things such as syntax
-;;; highlighting, presentation types, etc), through specializing on
-;;; the generic function `display-syntax-view'. Methods defined on
-;;; this function can assume that they are writing to a normal CLIM
-;;; stream pane, but cannot expect that they are the only Drei
-;;; instance on the stream, and cannot assume that they completely
-;;; control the stream. The redisplay scaffolding code will take care
-;;; of packaging the output records generated by methods into
-;;; something useful to the concrete Drei implementation.
-;;;
;;; The basic Drei redisplay functions:
(defgeneric display-drei-view-contents (stream view)
@@ -69,13 +59,7 @@
(letf (((stream-default-view stream) view))
(call-next-method)))
(:method ((stream extended-output-stream) (view drei-syntax-view))
- (display-syntax-view stream view (syntax view))))
-
-(defgeneric display-syntax-view (stream view syntax)
- (:documentation "Display `view', which contains a view of a
-buffer considered to be in syntax `syntax', on `stream'. This
-function is called by `display-drei-view-contents' whenever it is
-asked to display a syntax view."))
+ (call-next-method)))
(defgeneric display-drei-view-cursor (stream view cursor)
(:documentation "The purpose of this function is to display a
@@ -96,23 +80,681 @@
applicable. This method will only be called by the Drei redisplay
engine when the cursor is active and the buffer position it
refers to is on display - therefore, `offset-to-screen-position'
-is *guaranteed* to not return NIL or T.")
+is *guaranteed* to not return NIL or T. This function will return
+either the output record of the cursor, or NIL.")
(:method :around ((stream extended-output-stream) (view drei-view)
(cursor drei-cursor))
(when (visible cursor view)
(letf (((stream-default-view stream) view))
(call-next-method)))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The standard redisplay implementation for buffer views.
+
+(defstruct face
+ "A face is a description of how to draw (primarily) text, it
+consists of an ink (a colour) and a text style. The text style
+may be incomplete, in which case it is merged with the default
+text style whenever it needs to be used."
+ (ink +foreground-ink+)
+ (style nil))
+
+(defconstant +default-stroke-drawer-dispatcer+
+ #'(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.")
+
+(defstruct drawing-options
+ "A set of options for how to display a stroke."
+ (face (make-face))
+ (function +default-stroke-drawer-dispatcer+))
+
+(defun drawing-options-equal (o1 o2)
+ "Return true if `o1' and `o2' are equal, that is, they specify
+the same options. Does not take the drawing-function into account
+due to the halting problem (and also, for more practical
+reasons), with the exception that no `drawing-options' object
+with a non-`stroke-drawing-fn' drawing function is equivalent to
+a `drawing-options' with a `stroke-drawing-fn' drawing function."
+ (let ((f1 (drawing-options-face o1))
+ (f2 (drawing-options-face o2)))
+ (and (equal (face-ink f1) (face-ink f2))
+ (equal (face-style f1) (face-style f2))
+ (or (not (eq (drawing-options-function o1)
+ +default-stroke-drawer-dispatcer+))
+ (eq (drawing-options-function o2)
+ +default-stroke-drawer-dispatcer+))
+ (or (not (eq (drawing-options-function o2)
+ +default-stroke-drawer-dispatcer+))
+ (eq (drawing-options-function o1)
+ +default-stroke-drawer-dispatcer+)))))
+
+(defconstant +default-drawing-options+ (make-drawing-options)
+ "The default set of drawing options used for strokes when
+nothing else has been specified, or when the default is good
+enough. Under these options, the region will be printed as a
+string with the default foreground color.")
+
+(defstruct (dimensions :conc-name)
+ "A simple mutable rectangle structure. The coordinates should
+be absolute coordinates in the coordinate system of a sheet."
+ (x1 0)
+ (y1 0)
+ (x2 0)
+ (y2 0))
+
+(defun dimensions-height (dimensions)
+ "Return the width of the provided `dimensions' object."
+ (- (y2 dimensions) (y1 dimensions)))
+
+(defun dimensions-width (dimensions)
+ "Return the width of the provided `dimensions' object."
+ (- (x2 dimensions) (x1 dimensions)))
+
+(defun coordinates-intersects-dimensions (dimensions x1 y1 x2 y2)
+ "Return true if the rectangle defined by (x1, y1), (x2, y2)
+intersects with the rectangle defined by `dimensions'."
+ (and (or (<= x1 (x1 dimensions) x2)
+ (<= x1 (x2 dimensions) x2)
+ (<= (x1 dimensions) x1 (x2 dimensions))
+ (<= (x1 dimensions) x2 (x2 dimensions)))
+ (or (<= y1 (y1 dimensions) y2)
+ (<= y1 (y2 dimensions) y2)
+ (<= (y1 dimensions) y1 (y2 dimensions))
+ (<= (y1 dimensions) y2 (y2 dimensions)))))
+
+(defstruct (displayed-stroke (:conc-name stroke-))
+ "A stroke is a description of how a buffer region (`start-offset',
+`end-offset') is displayed on the screen. If `dirty' is true,
+something has obscured or scribbled over the part of the screen
+area taken up by the stroke. If `modified' is true, this stroke
+object might output something different than the last time it was
+redisplayed, and should thus update any caches or similar. When
+`modified' is set, `dirty' probably also should be set."
+ (start-offset)
+ (end-offset)
+ (drawing-options +default-drawing-options+)
+ (dirty t)
+ (modified t)
+ (dimensions (make-dimensions)))
+
+(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
+strokes. `Stroke-count' tells how many of the stroke objects in
+`stroke' are actually live, and how many are old, stale objects
+to prevent the need for consing if new strokes are added to the
+line."
+ (start-offset)
+ (end-offset)
+ (dimensions (make-dimensions))
+ (strokes (make-array 0 :adjustable t))
+ (stroke-count 0))
+
+(defgeneric pump-state-for-offset (view offset)
+ (:documentation "Return a pump state that will enable pumping
+strokes from `offset' in the buffer of `view' (via
+`stroke-pump'). The pump state is not guaranteed to be valid past
+the next call to `stroke-pump' or `synchronize-view'."))
+
+(defgeneric stroke-pump (view stroke pump-state)
+ (:documentation "Put stroke information in `stroke'. Returns
+new pump-state."))
+
+(defun in-place-buffer-substring (buffer string offset1 offset2)
+ "Copy from `offset1' to `offset2' in `buffer' to `string',
+which must be an adjustable vector of characters with a fill
+pointer. All objects in the buffer range must be
+characters. Returns `string'."
+ (loop for offset from offset1 below offset2
+ for i upfrom 0
+ do (vector-push-extend (buffer-object buffer offset) string)
+ finally (return string)))
+
+(defun fill-string-from-buffer (buffer string offset1 offset2)
+ "Copy from `offset1' to `offset2' in `buffer' to `string',
+which must be an adjustable vector of characters with a fill
+pointer. Once the buffer region has been copied to `string', or a
+non-character object has been encountered in the buffer, the
+number of characters copied to `string' will be returned."
+ (loop for offset from offset1 below offset2
+ for i upfrom 0
+ if (characterp (buffer-object buffer offset))
+ do (vector-push-extend (buffer-object buffer offset) string)
+ else do (loop-finish)
+ finally (return i)))
+
+(defun clear-rectangle* (stream x1 y1 x2 y2)
+ "Draw on `stream' from (x1,y1) to (x2,y2) with the background
+ink for the stream."
+ (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
+
+(defun invalidate-line-strokes (line &key modified cleared)
+ "Invalidate all the strokes of `line' 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."
+ (loop for stroke across (line-strokes line)
+ do (setf (stroke-dirty stroke) t
+ (stroke-modified stroke)
+ (or (stroke-modified stroke)
+ modified
+ cleared))
+ when cleared
+ do (let ((dimensions (stroke-dimensions stroke)))
+ (setf (x1 dimensions) 0
+ (y1 dimensions) 0
+ (x2 dimensions) 0
+ (y2 dimensions) 0))))
+
+(defun invalidate-all-strokes (view &key modified cleared)
+ "Invalidate all the strokes of `view' 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."
+ (loop for line across (displayed-lines view)
+ do (invalidate-line-strokes line
+ :modified modified :cleared cleared)))
+
+(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."
+ (check-type line-sym symbol)
+ (with-gensyms (line-index)
+ (once-only (view)
+ `(dotimes (,line-index (displayed-lines-count ,view))
+ (let ((,line-sym (aref (displayed-lines ,view) ,line-index)))
+ , at body)))))
+
+(defmacro do-undisplayed-lines ((line-sym view) &body body)
+ "Loop over lines not on display for `view', evaluating `body'
+with `line-sym' bound to the `displayed-line' object for each
+line."
+ (check-type line-sym symbol)
+ (with-gensyms (line-index)
+ (once-only (view)
+ `(dotimes (,line-index (- (length (displayed-lines ,view)) (displayed-lines-count ,view)))
+ (let ((,line-sym (aref (displayed-lines ,view)
+ (+ (displayed-lines-count ,view) ,line-index))))
+ , at body)))))
+
+(defmacro do-displayed-line-strokes ((stroke-sym line &optional) &body body)
+ "Loop over the displayed strokes of `line', evaluating `body'
+with `stroke-sym' bound to the `displayed-stroke' object for each
+line."
+ (check-type stroke-sym symbol)
+ (with-gensyms (stroke-index)
+ (once-only (line)
+ `(dotimes (,stroke-index (line-stroke-count ,line))
+ (let* ((,stroke-sym (aref (line-strokes ,line) ,stroke-index)))
+ , at body)))))
+
+(defmacro do-undisplayed-line-strokes ((stroke-sym line &optional) &body body)
+ "Loop over the undisplayed strokes of `line', evaluating `body'
+with `stroke-sym' bound to the `displayed-stroke' object for each
+line."
+ (check-type stroke-sym symbol)
+ (with-gensyms (stroke-index)
+ (once-only (line)
+ `(dotimes (,stroke-index (- (length (line-strokes ,line)) (line-stroke-count ,line)))
+ (let* ((,stroke-sym (aref (line-strokes ,line)
+ (+ (line-stroke-count ,line) ,stroke-index))))
+ , at body)))))
+
+(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
+NIL."
+ (do-displayed-lines (line view)
+ (when (<= (line-start-offset line) offset (line-end-offset line))
+ (do-displayed-line-strokes (stroke line)
+ (when (and (<= (stroke-start-offset stroke) offset
+ (end-offset (stroke-end-offset stroke))))
+ (return stroke))))))
+
+(defun ensure-line-information-size (view min-size)
+ "Ensure that the array of lines for `view' contains at least
+`min-size' elements."
+ (with-accessors ((displayed-lines displayed-lines)) view
+ (setf displayed-lines
+ (ensure-array-size displayed-lines min-size
+ #'make-displayed-line))))
+
+(defun line-information (view index)
+ "Return the `index'th `displayed-line' object of `view'."
+ (ensure-line-information-size view (1+ index))
+ (elt (displayed-lines view) index))
+
+(defun last-displayed-line (view)
+ "Return the last line on display for `view', will result in an
+error if there is no such line (note that even an empty buffer
+consists of a single line on display, as long as it has been
+redislayed at some point)."
+ (elt (displayed-lines view) (1- (displayed-lines-count view))))
+
+(defun ensure-line-stroke-information-size (line min-size)
+ "Ensure that the array of strokes in `line' contains at least
+`min-size' elements."
+ (with-accessors ((line-strokes line-strokes)) line
+ (setf line-strokes
+ (ensure-array-size line-strokes min-size
+ #'make-displayed-stroke))))
+
+(defun line-stroke-information (line stroke-number)
+ "Return the `index'th `displayed-stroke' object of `line'."
+ (ensure-line-stroke-information-size line (1+ stroke-number))
+ (aref (line-strokes line) stroke-number))
+
+(defun line-last-stroke (line)
+ "Return the last stroke in `line', will result in an error if
+there is no such stroke (note that even an empty line consists of
+a single stroke on display, as long as it has been redislayed at
+some point)."
+ (aref (line-strokes line) (1- (line-stroke-count line))))
+
+(defun put-stroke (view line pump-state)
+ "Use `stroke-pump' with `pump-state' to get a new stroke for
+`view', and add it to the sequence of displayed strokes in
+`line'."
+ (let* ((stroke (line-stroke-information line (line-stroke-count line))))
+ (prog1 (stroke-pump view stroke pump-state)
+ (incf (line-stroke-count line))
+ (setf (line-end-offset line) (stroke-end-offset stroke)))))
+
+(defun record-stroke (stroke x1 y1 x2 y2)
+ "Record the fact that `stroke' has been drawn, and that it
+covers the specified area on screen. Updates the dirty- and
+modified-bits of `stroke' as well as the dimensions."
+ (let ((dimensions (stroke-dimensions stroke)))
+ (setf (stroke-dirty stroke) nil
+ (stroke-modified stroke) nil
+ (x1 dimensions) x1
+ (y1 dimensions) y1
+ (x2 dimensions) x2
+ (y2 dimensions) y2)))
+
+(defun stroke-drawing-fn (stream view stroke cursor-x cursor-y)
+ "Draw `stroke' to `stream' 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."
+ (with-accessors ((start-offset stroke-start-offset)
+ (end-offset stroke-end-offset)
+ (dimensions stroke-dimensions)
+ (drawing-options stroke-drawing-options)) stroke
+ (let* ((stroke-string (in-place-buffer-substring
+ (buffer view) (cache-string view)
+ start-offset end-offset)))
+ (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) dimensions
+ (multiple-value-bind (width height) (if (stroke-modified stroke)
+ (text-size stream stroke-string
+ :text-style (merge-text-styles
+ (face-style (drawing-options-face drawing-options))
+ (medium-default-text-style stream)))
+ (values (- x2 x1) (- y2 y1)))
+ (clear-rectangle* stream cursor-x cursor-y
+ (+ cursor-x width) (+ cursor-y height
+ (stream-vertical-spacing stream)))
+ (draw-text* stream stroke-string cursor-x cursor-y
+ :text-style (face-style (drawing-options-face drawing-options))
+ :ink (face-ink (drawing-options-face drawing-options))
+ :align-y :top)
+ (record-stroke stroke cursor-x cursor-y (+ width cursor-x)
+ (+ (if (zerop height)
+ (text-style-height (medium-text-style stream) stream)
+ height)
+ cursor-y)))))))
+
+(defun draw-stroke (stream view stroke cursor-x cursor-y line-height)
+ "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)))
+ (when (stroke-dirty stroke)
+ (let ((old-dimensions (stroke-dimensions stroke)))
+ (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) old-dimensions
+ (unless (or (= x1 y1 x2 y2 0))
+ ;; Take care not to clear any previously drawn strokes.
+ (clear-rectangle* stream (max cursor-x x1) (max cursor-y y1)
+ (max x2 cursor-x) (+ (max (+ (max cursor-y y1) line-height) y2)
+ (stream-vertical-spacing stream))))
+ (funcall (drawing-options-function drawing-options) stream view stroke
+ cursor-x cursor-y #'stroke-drawing-fn))))))
+
+(defun end-line (line x1 y1 line-width line-height)
+ "End the addition of strokes to `line' for now, and update the
+dimensions of `line'."
+ (let ((dimensions (line-dimensions line)))
+ (setf (x1 dimensions) x1
+ (y1 dimensions) y1
+ (x2 dimensions) (+ x1 line-width)
+ (y2 dimensions) (+ y1 line-height))))
+
[622 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/28 10:08:33 1.27
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/01 18:43:36 1.28
@@ -139,7 +139,7 @@
(defpackage :drei-syntax
(:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils)
(:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp
- #:define-syntax #:*default-syntax* #:cursor-positions
+ #:define-syntax #:*default-syntax*
#:syntax-command-table #:additional-command-tables #:define-syntax-command-table
#:eval-option
#:define-option-for-syntax
@@ -187,7 +187,7 @@
#:display-drei #:display-drei-pane #:display-drei-area #:full-redisplay
#:offset-to-screen-position
#:page-down #:page-up
- #:isearch-state #:search-string #:search-mark #:search-buffer
+ #:isearch-state #:search-string #:search-mark
#:search-forward-p #:search-success-p
#:query-replace-state #:string1 #:string2 #:targets #:occurrences
--- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/28 10:08:35 1.8
+++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/01 18:43:36 1.9
@@ -455,7 +455,9 @@
(:documentation "Synchronize the view with the object under
observation - what exactly this entails, and what keyword
arguments are supported, is up to the individual view
-subclass."))
+subclass.")
+ (:method ((view drei-view) &key)
+ nil))
(defgeneric view-command-tables (view)
(:documentation "Return a list of command tables containing
@@ -506,8 +508,28 @@
(%bot :accessor bot
:documentation "The bottom of the displayed buffer, that
is, the mark indicating the last visible object in the buffer.")
- (%cursor-positions :accessor cursor-positions
- :initform nil))
+ (%cache-string :reader cache-string
+ :initform (make-array 0 :element-type 'character
+ :adjustable t
+ :fill-pointer 0)
+ :documentation "A string used during redisplay
+to reduce consing. Instead of consing up a new string every time
+we need to pull out a buffer region, we put it in this
+string. The fill pointer is automatically set to zero whenever
+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))
+ :type array
+ :documentation "An array of the
+`displayed-line' objects displayed by the view. Not all of these
+are live.")
+ (%displayed-lines-count :accessor displayed-lines-count
+ :initform 0
+ :type integer
+ :documentation "The number of lines in
+the views `displayed-lines' array that are actually live, that
+is, used for display right now."))
(:documentation "A view that contains a `drei-buffer'
object."))
@@ -517,6 +539,33 @@
(setf top (make-buffer-mark buffer 0 :left)
bot (make-buffer-mark buffer (size buffer) :right))))
+(defmethod (setf top) :after (new-value (view drei-buffer-view))
+ (invalidate-all-strokes view))
+
+(defmethod (setf bot) :after (new-value (view drei-buffer-view))
+ (invalidate-all-strokes view))
+
+(defmethod (setf buffer) :after (new-value (view drei-buffer-view))
+ (invalidate-all-strokes view))
+
+(defmethod cache-string :around ((view drei-buffer-view))
+ (let ((string (call-next-method)))
+ (setf (fill-pointer string) 0)
+ string))
+
+(defmethod observer-notified ((view drei-buffer-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)
+ (dotimes (i (displayed-lines-count view))
+ (let ((line (line-information view i)))
+ (when (<= (car changed-region) (line-end-offset line))
+ (invalidate-line-strokes line :modified t))))))
+
(defclass drei-syntax-view (drei-buffer-view)
((%syntax :accessor syntax)
(%prefix-size :accessor prefix-size
@@ -602,15 +651,6 @@
(disable-mode (syntax modual) mode-name)
(call-next-method)))
-(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)))
-
(defmethod synchronize-view :around ((view drei-syntax-view) &key
force-p)
;; If nothing changed, then don't call the other methods.
@@ -633,7 +673,8 @@
(suffix-size view) (size (buffer view))
(buffer-size view) (size (buffer view)))
(update-syntax (syntax view) prefix-size suffix-size
- begin end)))
+ begin end)
+ (call-next-method)))
(defun make-syntax-for-view (view syntax-symbol &rest args)
(apply #'make-instance syntax-symbol
More information about the Mcclim-cvs
mailing list