[gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.lisp gsharp/Flexichain/flexicursor.lisp
Robert Strandh
rstrandh at common-lisp.net
Fri Aug 6 15:47:36 UTC 2004
Update of /project/gsharp/cvsroot/gsharp/Flexichain
In directory common-lisp.net:/tmp/cvs-serv27009
Modified Files:
flexichain.lisp flexicursor.lisp
Log Message:
Completely modified the implementation of cursors.
Now, a cursorchain can hold a large number of cursors without any
negative impact on performance.
For cursorchains, the flexichain buffer now has a parallel that holds
per-element lists of cursors that stick to that element.
Introduced new generic functions in the internal protocol fill-gap and
resize-buffer.
Updated the documentation accordingly.
Date: Fri Aug 6 08:47:36 2004
Author: rstrandh
Index: gsharp/Flexichain/flexichain.lisp
diff -u gsharp/Flexichain/flexichain.lisp:1.1 gsharp/Flexichain/flexichain.lisp:1.2
--- gsharp/Flexichain/flexichain.lisp:1.1 Sun Aug 1 08:27:19 2004
+++ gsharp/Flexichain/flexichain.lisp Fri Aug 6 08:47:36 2004
@@ -385,15 +385,20 @@
(when (and (<= start2 data-start) (< data-start end2))
(incf data-start (- start1 start2)))))
+(defgeneric fill-gap (standard-flexichain start end)
+ (:documentation "fill part of gap with the fill element"))
+
+(defmethod fill-gap ((fc standard-flexichain) start end)
+ (with-slots (buffer fill-element) fc
+ (fill buffer fill-element :start start :end end)))
+
(defun push-elements-left (chain count)
"Pushes the COUNT elements of CHAIN at the right of the gap,
to the beginning of the gap. The gap must be continuous. Example:
PUSH-ELEMENTS-LEFT abcd-----efghijklm 2 => abcdef-----ghijklm"
- (with-slots (buffer gap-start gap-end fill-element) chain
+ (with-slots (buffer gap-start gap-end) chain
(move-elements chain buffer buffer gap-start gap-end (+ gap-end count))
- (fill buffer fill-element
- :start (max gap-end (+ gap-start count))
- :end (+ gap-end count))
+ (fill-gap chain (max gap-end (+ gap-start count)) (+ gap-end count))
(incf gap-start count)
(incf gap-end count)
(normalize-indices chain)))
@@ -402,14 +407,12 @@
"Pushes the COUNT elements of CHAIN at the left of the gap,
to the end of the gap. The gap must be continuous. Example:
PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2 => ab-----cdefghijklm"
- (with-slots (buffer gap-start gap-end fill-element) chain
+ (with-slots (buffer gap-start gap-end) chain
(let* ((buffer-size (length buffer))
(rotated-gap-end (if (zerop gap-end) buffer-size gap-end)))
(move-elements chain buffer buffer
(- rotated-gap-end count) (- gap-start count) gap-start)
- (fill buffer fill-element
- :start (- gap-start count)
- :end (min gap-start (- rotated-gap-end count)))
+ (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count)))
(decf gap-start count)
(setf gap-end (- rotated-gap-end count))
(normalize-indices chain))))
@@ -418,13 +421,12 @@
"Moves the COUNT rightmost elements to the end of the gap,
on the left of the data. Example:
HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2 => -lmabcdefghijk-----"
- (with-slots (buffer gap-start gap-end fill-element) chain
+ (with-slots (buffer gap-start gap-end) chain
(let* ((buffer-size (length buffer))
(rotated-gap-start (if (zerop gap-start) buffer-size gap-start)))
(move-elements chain buffer buffer
(- gap-end count) (- rotated-gap-start count) rotated-gap-start)
- (fill buffer fill-element
- :start (- rotated-gap-start count) :end rotated-gap-start)
+ (fill-gap chain (- rotated-gap-start count) rotated-gap-start)
(setf gap-start (- rotated-gap-start count))
(decf gap-end count)
(normalize-indices chain))))
@@ -433,9 +435,9 @@
"Moves the COUNT leftmost elements to the beginning of the gap,
on the right of the data. Example:
HOP-ELEMENTS-RIGHT ---abcdefghijklm--- 2 => -----cdefghijklmab-"
- (with-slots (buffer gap-start gap-end fill-element) chain
+ (with-slots (buffer gap-start gap-end) chain
(move-elements chain buffer buffer gap-start gap-end (+ gap-end count))
- (fill buffer fill-element :start gap-end :end (+ gap-end count))
+ (fill-gap chain gap-end (+ gap-end count))
(incf gap-start count)
(incf gap-end count)
(normalize-indices chain)))
@@ -446,31 +448,34 @@
(defun decrease-buffer-size (chain)
(resize-buffer chain (required-space chain (nb-elements chain))))
-(defun resize-buffer (chain new-buffer-size)
+(defgeneric resize-buffer (standard-flexichain new-buffer-size)
+ (:documentation "allocate a new buffer with the size indicated"))
+
+(defmethod resize-buffer ((fc standard-flexichain) new-buffer-size)
(with-slots (buffer gap-start gap-end
- fill-element element-type expand-factor) chain
+ fill-element element-type expand-factor) fc
(let ((buffer-size (length buffer))
(buffer-after (make-array new-buffer-size
:element-type element-type
:initial-element fill-element)))
- (case (gap-location chain)
+ (case (gap-location fc)
((:gap-empty :gap-middle)
- (move-elements chain buffer-after buffer 0 0 gap-start)
+ (move-elements fc buffer-after buffer 0 0 gap-start)
(let ((gap-end-after (- new-buffer-size (- buffer-size gap-end))))
- (move-elements chain buffer-after buffer gap-end-after gap-end buffer-size)
+ (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size)
(setf gap-end gap-end-after)))
(:gap-right
- (move-elements chain buffer-after buffer 0 0 gap-start))
+ (move-elements fc buffer-after buffer 0 0 gap-start))
(:gap-left
- (let ((gap-end-after (- new-buffer-size (nb-elements chain))))
- (move-elements chain buffer-after buffer gap-end-after gap-end buffer-size)
+ (let ((gap-end-after (- new-buffer-size (nb-elements fc))))
+ (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size)
(setf gap-end gap-end-after)))
(:gap-non-contiguous
- (move-elements chain buffer-after buffer 0 gap-end gap-start)
+ (move-elements fc buffer-after buffer 0 gap-end gap-start)
(decf gap-start gap-end)
(setf gap-end 0)))
(setf buffer buffer-after)))
- (normalize-indices chain))
+ (normalize-indices fc))
(defun normalize-indices (chain)
"Sets gap limits to 0 if they are at the end of the buffer."
Index: gsharp/Flexichain/flexicursor.lisp
diff -u gsharp/Flexichain/flexicursor.lisp:1.1 gsharp/Flexichain/flexicursor.lisp:1.2
--- gsharp/Flexichain/flexicursor.lisp:1.1 Sun Aug 1 08:27:19 2004
+++ gsharp/Flexichain/flexicursor.lisp Fri Aug 6 08:47:36 2004
@@ -101,41 +101,74 @@
(:documentation "Replaces the element immediately after the cursor."))
(defclass standard-cursorchain (cursorchain standard-flexichain)
- ((cursors :accessor cursorchain-cursors :initform '()))
+ ((cursors :accessor cursorchain-cursors)
+ (temp-cursors :initform nil))
(:documentation "The standard instantiable subclass of CURSORCHAIN"))
+(defmethod initialize-instance :after ((cc standard-cursorchain) &rest args)
+ (declare (ignore args))
+ (with-slots (buffer cursors) cc
+ (setf cursors (make-array (length buffer) :initial-element '()))))
+
+(defmethod resize-buffer :around ((cc standard-cursorchain) new-buffer-size)
+ (with-slots (cursors temp-cursors) cc
+ (setf temp-cursors (make-array new-buffer-size :initial-element '()))
+ (call-next-method)
+ (setf cursors temp-cursors
+ temp-cursors nil)))
+
+(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
+ (declare (ignore to from))
+ (with-slots (cursors temp-cursors) cc
+ (let ((destination (or temp-cursors cursors)))
+ (replace destination cursors :start1 start1 :start2 start2 :end2 end2)
+ (loop for i from start1 below (+ start1 (- end2 start2))
+ do (setf (aref destination i)
+ (loop for cursor-wp in (aref destination i)
+ as cursor = (weak-pointer-value cursor-wp)
+ when cursor
+ do (setf (flexicursor-index cursor) i)
+ and collect cursor-wp))))))
+
+(defmethod fill-gap :after ((cc standard-cursorchain) start end)
+ (with-slots (cursors) cc
+ (fill cursors '() :start start :end end)))
+
(defclass standard-flexicursor (flexicursor)
((chain :reader chain :initarg :chain)
- (index :accessor flexicursor-index :initarg :index))
+ (index :accessor flexicursor-index))
(:documentation "The standard instantiable subclass of FLEXICURSOR"))
(defclass left-sticky-flexicursor (standard-flexicursor) ())
(defclass right-sticky-flexicursor (standard-flexicursor) ())
-(defmethod initialize-instance :after ((cursor standard-flexicursor)
- &rest initargs)
- (declare (ignore initargs))
- (with-slots (chain) cursor
- (push (make-weak-pointer cursor)
- (cursorchain-cursors chain))))
-
(defmethod initialize-instance :after ((cursor left-sticky-flexicursor)
&rest initargs)
(declare (ignore initargs))
(with-slots (index chain) cursor
- (setf index (slot-value chain 'data-start))))
+ (setf index (slot-value chain 'data-start))
+ (with-slots (cursors) chain
+ (push (make-weak-pointer cursor)
+ (aref cursors (slot-value chain 'data-start))))))
(defmethod initialize-instance :after ((cursor right-sticky-flexicursor)
&rest initargs)
(declare (ignore initargs))
(with-slots (index chain) cursor
- (setf index (position-index chain 0))))
+ (setf index (position-index chain 0))
+ (with-slots (cursors) chain
+ (push (make-weak-pointer cursor)
+ (aref cursors (position-index chain 0))))))
(defmethod clone-cursor ((cursor standard-flexicursor))
(let ((result (make-instance (class-of cursor)
:chain (chain cursor))))
- (setf (slot-value result 'index) (slot-value cursor 'index))))
+ (setf (slot-value result 'index) (slot-value cursor 'index))
+ (with-slots (cursors) (chain cursor)
+ (push (make-weak-pointer result)
+ (aref cursors (slot-value cursor 'index))))
+ result))
(defmethod cursor-pos ((cursor left-sticky-flexicursor))
(1+ (index-position (chain cursor) (slot-value cursor 'index))))
@@ -167,7 +200,15 @@
(t (let ((cursor-pos (cursor-pos cursor)))
(assert (<= (+ n cursor-pos) (nb-elements (chain cursor))) ()
'at-end-error :cursor cursor)
- (setf (cursor-pos cursor) (+ cursor-pos n))))))
+ (with-slots (cursors) (chain cursor)
+ (with-slots (index) cursor
+ (setf (aref cursors index)
+ (delete cursor (aref cursors index)
+ :test #'eq
+ :key #'weak-pointer-value))
+ (setf (cursor-pos cursor) (+ cursor-pos n))
+ (push (make-weak-pointer cursor)
+ (aref cursors index))))))))
(defmethod move< ((cursor standard-flexicursor) &optional (n 1))
(cond ((minusp n) (move> cursor (- n)))
@@ -175,15 +216,15 @@
(t (let ((cursor-pos (cursor-pos cursor)))
(assert (>= cursor-pos n) ()
'at-beginning-error :cursor cursor)
- (setf (cursor-pos cursor) (- cursor-pos n))))))
-
-(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
- (loop for cursor-wp in (cursorchain-cursors cc)
- as cursor = (weak-pointer-value cursor-wp)
- do (when cursor
- (with-slots (index) cursor
- (when (and (<= start2 index) (< index end2))
- (incf index (- start1 start2)))))))
+ (with-slots (cursors) (chain cursor)
+ (with-slots (index) cursor
+ (setf (aref cursors index)
+ (delete cursor (aref cursors index)
+ :test #'eq
+ :key #'weak-pointer-value))
+ (setf (cursor-pos cursor) (- cursor-pos n))
+ (push (make-weak-pointer cursor)
+ (aref cursors index))))))))
(defmethod insert ((cursor standard-flexicursor) object)
(insert* (chain cursor) (cursor-pos cursor) object))
@@ -194,16 +235,16 @@
(insert cursor object))
sequence))
-(defmethod delete* :around ((chain standard-flexichain) position)
+(defmethod delete* :around ((chain standard-cursorchain) position)
(with-slots (cursors) chain
- (let* ((index (position-index chain position))
- (save (loop for cursor-wp in cursors
- as cursor = (weak-pointer-value cursor-wp)
- when (and cursor (= (slot-value cursor 'index) index))
- collect cursor)))
+ (let ((save (aref cursors (position-index chain position))))
(call-next-method)
- (loop for cursor in save
- do (setf (cursor-pos cursor) position)))))
+ (loop for cursor-wp in save
+ as cursor = (weak-pointer-value cursor-wp)
+ when cursor
+ do (setf (cursor-pos cursor) position)
+ and do (push cursor-wp
+ (aref cursors (flexicursor-index cursor)))))))
(defmethod delete> ((cursor standard-flexicursor) &optional (n 1))
(let ((chain (chain cursor))
More information about the Gsharp-cvs
mailing list