[gsharp-cvs] CVS update: gsharp/Flexichain/flexicursor.lisp

[Robert Strandh]

Update of /project/gsharp/cvsroot/gsharp/Flexichain
In directory common-lisp.net:/tmp/cvs-serv25678

Modified Files:
	flexicursor.lisp 
Log Message:
Unfortunately, despite much testing, there seems to be a bug in the
skiplist code.  And since it is very hard to test, due to its
probabilistic nature, I prefer taking it out of the flexichain code.
Consequently, the cursors are now organized in a simple list.  This
means that it is best not to have too many cursors.  However, this can
be better in some respects, because now, moving a cursor is faster,
and the penalty occurs only when elements have to be moved or deleted.
Most applications will do more insertions than deletions anyway.


Date: Mon Jan  3 07:44:42 2005
Author: rstrandh

Index: gsharp/Flexichain/flexicursor.lisp
diff -u gsharp/Flexichain/flexicursor.lisp:1.8 gsharp/Flexichain/flexicursor.lisp:1.9
--- gsharp/Flexichain/flexicursor.lisp:1.8	Mon Sep  6 13:25:52 2004
+++ gsharp/Flexichain/flexicursor.lisp	Mon Jan  3 07:44:42 2005
@@ -97,7 +97,7 @@
   (:documentation "Replaces the element immediately after the cursor."))
 
 (defclass standard-cursorchain (cursorchain standard-flexichain)
-  ((cursors :initform (make-instance 'skiplist) :accessor cursorchain-cursors))
+  ((cursors :initform '()))
   (:documentation "The standard instantiable subclass of CURSORCHAIN"))
 
 (defun make-wp (value)
@@ -108,32 +108,6 @@
   #+sbcl (sb-ext:weak-pointer-value wp)
   #+cmu  (ext:weak-pointer-value wp))
 
-(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
-  (declare (ignore to from))
-  (let ((addfun (lambda (key wp-cursors)
-		  (let ((increment (- start1 start2)))
-		    (loop for wp in wp-cursors
-			  as cursor = (wp-value wp)
-			  unless (null cursor)
-			    do (incf (flexicursor-index cursor) increment))
-		    (+ key increment)))))
-    (with-slots (cursors gap-start gap-end) cc
-       (cond ((= start1 start2) nil)
-	     ((= gap-start gap-end)
-	      (skiplist-slide-keys cursors start2 (1- end2) addfun))
-	     ((< gap-end gap-start)
-	      (cond ((and (= end2 gap-start) (> start1 start2))
-		     (skiplist-slide-keys cursors start2 (1- end2) addfun))
-		    ((= end2 gap-start)
-		     (skiplist-rotate-suffix cursors start2 addfun))
-		    (t (skiplist-rotate-prefix cursors (1- end2) addfun))))
-	     ((plusp gap-start)
-	      (skiplist-slide-keys cursors start2 (1- end2) addfun))
-	     ((= start2 gap-end)
-	      (skiplist-slide-keys cursors start2 (1- end2) addfun))
-	     (t
-	      (skiplist-rotate-suffix cursors start2 addfun))))))
-
 (defclass standard-flexicursor (flexicursor)
   ((chain :reader chain :initarg :chain)
    (index :accessor flexicursor-index))
@@ -149,7 +123,7 @@
   (with-slots (index chain) cursor
      (setf index (position-index chain (1- position)))
      (with-slots (cursors) chain
-	(push (make-wp cursor) (skiplist-find cursors index)))))
+	(push (make-wp cursor) cursors))))
 
 (defmethod initialize-instance :after ((cursor right-sticky-flexicursor)
 				       &rest initargs &key (position 0))
@@ -157,7 +131,30 @@
   (with-slots (index chain) cursor
      (setf index (position-index chain position))
      (with-slots (cursors) chain
-	(push (make-wp cursor) (skiplist-find cursors index)))))
+	(push (make-wp cursor) cursors))))
+
+(defun adjust-cursors (cursors start end increment)
+  (let ((acc '()))
+    (loop while cursors
+	  do (cond ((null (wp-value (car cursors)))
+		    (pop cursors))
+		   ((<= start (flexicursor-index (wp-value (car cursors))) end)
+		    (incf (flexicursor-index (wp-value (car cursors))) increment)
+		    (let ((rest (cdr cursors)))
+		      (setf (cdr cursors) acc
+			    acc cursors
+			    cursors rest)))
+		   (t
+		    (let ((rest (cdr cursors)))
+		      (setf (cdr cursors) acc
+			    acc cursors
+			    cursors rest)))))
+    acc))
+
+(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
+  (declare (ignore to from))
+  (with-slots (cursors) cc
+     (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2)))))
 
 (defmethod clone-cursor ((cursor standard-flexicursor))
   (make-instance (class-of cursor)
@@ -172,13 +169,7 @@
 	  'flexi-position-error :chain (chain cursor) :position position)
   (with-slots (chain index) cursor
      (with-slots (cursors) chain
-	(let ((remaining (delete cursor (skiplist-find cursors index)
-				 :key #'wp-value :test #'eq)))
-	  (if (null remaining)
-	      (skiplist-delete cursors index)
-	      (setf (skiplist-find cursors index) remaining)))
-	(setf index (position-index chain (1- position)))
-	(push (make-wp cursor) (skiplist-find cursors index)))))
+	(setf index (position-index chain (1- position))))))
 
 (defmethod cursor-pos ((cursor right-sticky-flexicursor))
   (index-position (chain cursor) (slot-value cursor 'index)))
@@ -188,13 +179,7 @@
 	  'flexi-position-error :chain (chain cursor) :position position)
   (with-slots (chain index) cursor
      (with-slots (cursors) chain
-	(let ((remaining (delete cursor (skiplist-find cursors index)
-				 :key #'wp-value :test #'eq)))
-	  (if (null remaining)
-	      (skiplist-delete cursors index)
-	      (setf (skiplist-find cursors index) remaining)))
-	(setf index (position-index chain position))
-	(push (make-wp cursor) (skiplist-find cursors index)))))
+	(setf index (position-index chain position)))))
 
 (defmethod at-beginning-p ((cursor standard-flexicursor))
   (zerop (cursor-pos cursor)))
@@ -213,11 +198,10 @@
 
 (defmethod delete* :before ((chain standard-cursorchain) position)
   (with-slots (cursors) chain
-     (let* ((old-index (position-index chain position))
-	    (cursors-to-adjust (skiplist-find cursors old-index)))
-       (loop for cursor-wp in cursors-to-adjust
+     (let* ((old-index (position-index chain position)))
+       (loop for cursor-wp in cursors
 	     as cursor = (wp-value cursor-wp)
-	     when cursor
+	     when (and cursor (= old-index (flexicursor-index cursor)))
 	       do (typecase cursor
 		    (right-sticky-flexicursor (incf (cursor-pos cursor)))
 		    (left-sticky-flexicursor (decf (cursor-pos cursor))))))))