[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Fri Dec 31 13:33:09 UTC 2004
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv22282
Modified Files:
gui.lisp packages.lisp syntax.lisp
Log Message:
Simplified the redisplay routine. Introduced a cache of lines in
the form of a flexichain.
The ultra-fast redisplay is not yet in place, because I thought the
bottle neck was in Climacs, whereas it is in McCLIM. I know how to
fix that, though, by using :cache-test #'eq for cached lines. The
only problem with that is that the line has to be traversed (despite
being cached) in order that we can compute the position of the cursor.
This might involve either invalidating the line with the cursor on it,
so that it will be rescanned, or else rescanning it anyway, despite it
being cached.
Date: Fri Dec 31 14:33:07 2004
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.36 climacs/gui.lisp:1.37
--- climacs/gui.lisp:1.36 Fri Dec 31 07:39:21 2004
+++ climacs/gui.lisp Fri Dec 31 14:33:06 2004
@@ -354,10 +354,10 @@
(setf (filename buffer) filename
(name buffer) (pathname-filename filename)
(needs-saving buffer) nil)
+ (beginning-of-buffer point)
;; this one is needed so that the buffer modification protocol
;; resets the low and high marks after redisplay
- (redisplay-frame-panes *application-frame*)
- (beginning-of-buffer point))))
+ (redisplay-frame-panes *application-frame*))))
(define-named-command com-save-buffer ()
(let* ((buffer (buffer (win *application-frame*)))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.15 climacs/packages.lisp:1.16
--- climacs/packages.lisp:1.15 Wed Dec 29 17:03:21 2004
+++ climacs/packages.lisp Fri Dec 31 14:33:06 2004
@@ -56,7 +56,7 @@
#:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev))
(defpackage :climacs-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base)
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
(:export #:syntax #:basic-syntax #:texinfo-syntax
#:redisplay-pane #:redisplay-with-syntax #:full-redisplay
#:url))
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.12 climacs/syntax.lisp:1.13
--- climacs/syntax.lisp:1.12 Wed Dec 29 12:38:34 2004
+++ climacs/syntax.lisp Fri Dec 31 14:33:06 2004
@@ -38,11 +38,11 @@
((top :reader top)
(bot :reader bot)
(scan :reader scan)
- (saved-offset :initform nil :accessor saved-offset)
- (cursor-x :initform nil)
- (cursor-y :initform nil)
+ (cursor-x :initform 2)
+ (cursor-y :initform 2)
(space-width :initform nil)
- (tab-width :initform nil)))
+ (tab-width :initform nil)
+ (cache :initform nil)))
(defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane)
(declare (ignore args))
@@ -66,72 +66,97 @@
'string)
:stream pane)))
-;;(defmacro maybe-updating-output (stuff &body body)
-;; `(progn , at body))
-
- (defmacro maybe-updating-output (stuff &body body)
- `(updating-output ,stuff , at body))
-
-(defmethod display-line (pane (syntax basic-syntax))
- (with-slots (saved-offset bot scan cursor-x cursor-y space-width tab-width) syntax
- (flet ((compute-contents ()
- (unless (null saved-offset)
- (prog1 (coerce (buffer-sequence (buffer pane) saved-offset scan) 'string)
- (setf saved-offset nil)))))
- (macrolet ((output-word (&body body)
- `(let ((contents (compute-contents)))
- (if (null contents)
- ,(if body
- `(maybe-updating-output (pane :unique-id (incf id))
- , at body)
- `(progn))
- (progn
- (maybe-updating-output (pane :unique-id (incf id)
- :cache-value contents
- :cache-test #'string=)
- (present-contents contents pane syntax))
- ,(when body
- `(maybe-updating-output (pane :unique-id (incf id))
- , at body)))))))
- (loop with id = 0
+(defmethod display-line (pane (syntax basic-syntax) line)
+ (let ((saved-index nil)
+ (id 0))
+ (flet ((output-word (index)
+ (unless (null saved-index)
+ (let ((contents (coerce (subseq line saved-index index) 'string)))
+ (updating-output (pane :unique-id (incf id)
+ :cache-value contents
+ :cache-test #'string=)
+ (present-contents contents pane syntax)))
+ (setf saved-index nil))))
+ (with-slots (bot scan cursor-x cursor-y space-width tab-width) syntax
+ (loop for index from 0
+ for obj across line
when (mark= scan (point pane))
do (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x (+ x (if (null saved-offset)
+ (setf cursor-x (+ x (if (null saved-index)
0
- (* space-width (- scan saved-offset))))
+ (* space-width (- index saved-index))))
cursor-y y))
- when (mark= scan bot)
- do (output-word)
- (return)
- until (eql (buffer-object (buffer pane) scan) #\Newline)
- do (let ((obj (buffer-object (buffer pane) scan)))
- (cond ((eql obj #\Space)
- (output-word)
- (stream-increment-cursor-position pane space-width 0))
- ((eql obj #\Tab)
- (output-word)
- (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))
- ((constituentp obj)
- (when (null saved-offset)
- (setf saved-offset scan)))
- (t
- (output-word (princ obj pane)))))
+ do (cond ((eql obj #\Space)
+ (output-word index)
+ (stream-increment-cursor-position pane space-width 0))
+ ((eql obj #\Tab)
+ (output-word index)
+ (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0)))
+ ((constituentp obj)
+ (when (null saved-index)
+ (setf saved-index index)))
+ ((characterp obj)
+ (output-word index)
+ (updating-output (pane :unique-id (incf id)
+ :cache-value obj)
+ (present obj)))
+ (t
+ (output-word index)
+ (updating-output (pane :unique-id (incf id)
+ :cache-value obj
+ :cache-test #'eq)
+ (present obj))))
(incf scan)
- finally (output-word (terpri pane))
+ finally (output-word index)
+ (when (mark= scan (point pane))
+ (multiple-value-bind (x y) (stream-cursor-position pane)
+ (setf cursor-x x
+ cursor-y y)))
+ (terpri pane)
(incf scan))))))
-(defun round-up (x)
- (cond ((zerop x) 2)
- ((evenp x) x)
- (t (1+ x))))
+(defmethod compute-cache (pane (syntax basic-syntax))
+ (with-slots (top bot cache) syntax
+ (let* ((buffer (buffer pane))
+ (high-mark (high-mark buffer))
+ (low-mark (low-mark buffer)))
+ (when (or (mark< low-mark top) (mark> high-mark bot))
+ (setf cache nil))
+ (if (null cache)
+ (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot)))
+ (mark1 (clone-mark top))
+ (mark2 (clone-mark top)))
+ (setf cache (make-instance 'standard-flexichain))
+ (loop for line from 0 below nb-lines-on-display
+ do (beginning-of-line mark1)
+ (end-of-line mark2)
+ (insert* cache line (region-to-sequence mark1 mark2))
+ unless (end-of-buffer-p mark2)
+ do (setf (offset mark1) (1+ (offset mark2))
+ (offset mark2) (offset mark1))))
+ (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot)))
+ (mark1 (clone-mark low-mark))
+ (mark2 (clone-mark low-mark))
+ (size1 (number-of-lines-in-region top low-mark))
+ (size2 (number-of-lines-in-region high-mark bot)))
+ (loop repeat (- (nb-elements cache) size1 size2)
+ do (delete* cache size1))
+ (loop for line from size1
+ repeat (- nb-lines-on-display (nb-elements cache))
+ do (beginning-of-line mark1)
+ (end-of-line mark2)
+ (insert* cache line (region-to-sequence mark1 mark2))
+ unless (end-of-buffer-p mark2)
+ do (setf (offset mark1) (1+ (offset mark2))
+ (offset mark2) (offset mark1))))))))
-(defmethod redisplay-with-syntax (pane (syntax basic-syntax))
+(defun position-window (pane syntax)
(let* ((medium (sheet-medium pane))
(style (medium-text-style medium))
(height (text-style-height style medium)))
- (with-slots (top bot scan cursor-x cursor-y) syntax
+ (with-slots (top bot cache) syntax
(beginning-of-line top)
(end-of-line bot)
(multiple-value-bind (x y w h) (bounding-rectangle* pane)
@@ -141,13 +166,17 @@
;; adjust the region on display to fit the pane
(loop repeat (- nb-lines-on-display nb-lines-in-pane)
do (beginning-of-line bot)
- (decf (offset bot)))
+ (decf (offset bot))
+ (unless (null cache)
+ (pop-end cache)))
(loop until (end-of-buffer-p bot)
repeat (- nb-lines-in-pane nb-lines-on-display)
do (incf (offset bot))
- (end-of-line bot))
+ (end-of-line bot)
+ (setf cache nil))
;; move region on display if point is outside the current region
(when (or (mark< (point pane) top) (mark> (point pane) bot))
+ (setf cache nil)
(setf (offset top) (offset (point pane)))
(loop do (beginning-of-line top)
repeat (floor nb-lines-in-pane 2)
@@ -159,24 +188,38 @@
repeat (1- nb-lines-in-pane)
until (end-of-buffer-p bot)
do (incf (offset bot))
- (end-of-line bot)))
- (setf scan (offset top))
- (loop for id from 0
- until (mark= scan bot)
- do (maybe-updating-output (pane :unique-id id)
- (display-line pane syntax)))
- (when (mark= scan (point pane))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x x
- cursor-y y)))
- (maybe-updating-output (pane :all-new t :fixed-position t)
- (draw-line* pane
- ;; cursors with odd x-positions were invisible
- ;; so we strip off the low bit to make them even.
-
- (round-up cursor-x) (- cursor-y (* 0.2 height))
- (round-up cursor-x) (+ cursor-y (* 0.8 height))
- :ink +red+)))))))
+ (end-of-line bot))))))))
+
+
+;;; this one should not be necessary.
+(defun round-up (x)
+ (cond ((zerop x) 2)
+ ((evenp x) x)
+ (t (1+ x))))
+
+(defmethod redisplay-with-syntax (pane (syntax basic-syntax))
+ (let* ((medium (sheet-medium pane))
+ (style (medium-text-style medium))
+ (height (text-style-height style medium)))
+ (with-slots (top bot scan cache cursor-x cursor-y) syntax
+ (position-window pane syntax)
+ (compute-cache pane syntax)
+ (setf scan (offset top))
+ (loop for id from 0 below (nb-elements cache)
+ do (updating-output (pane :unique-id id)
+ (display-line pane syntax (element* cache id))))
+ (when (mark= scan (point pane))
+ (multiple-value-bind (x y) (stream-cursor-position pane)
+ (setf cursor-x x
+ cursor-y y)))
+ (updating-output (pane :unique-id -1)
+ (draw-line* pane
+ ;; cursors with odd or zero x-positions were invisible
+ ;; so we round them up to even.
+ ;; We don't know why, though.
+ (round-up cursor-x) (- cursor-y (* 0.2 height))
+ (round-up cursor-x) (+ cursor-y (* 0.8 height))
+ :ink +red+)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
More information about the Climacs-cvs
mailing list