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