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

[Robert Strandh]

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

Modified Files:
	flexicursor.lisp 
Added Files:
	rtester.lisp stupid.lisp 
Log Message:
Added a stupid (but straightforward) implementation of the flexichain
protocol.  The idea is to generate random test cases and compare the
result to that obtained with the stupid implementation. 

Added a random tester facility that uses the normal and the stupid 
implementations. 

Fixed a problem in the flexicursor implementation that made clone-cursor
do the wrong thing. Added initarg :position for creating flexicursors. 


Date: Wed Sep  1 07:55:11 2004
Author: rstrandh





Index: gsharp/Flexichain/flexicursor.lisp
diff -u gsharp/Flexichain/flexicursor.lisp:1.5 gsharp/Flexichain/flexicursor.lisp:1.6
--- gsharp/Flexichain/flexicursor.lisp:1.5	Sun Aug 22 07:01:02 2004
+++ gsharp/Flexichain/flexicursor.lisp	Wed Sep  1 07:55:11 2004
@@ -144,29 +144,25 @@
 (defclass right-sticky-flexicursor (standard-flexicursor) ())
 
 (defmethod initialize-instance :after ((cursor left-sticky-flexicursor)
-				       &rest initargs)
+				       &rest initargs &key (position 0))
   (declare (ignore initargs))
   (with-slots (index chain) cursor
-     (setf index (slot-value chain 'data-start))
+     (setf index (position-index chain (1- position)))
      (with-slots (cursors) chain
 	(push (make-wp cursor) (skiplist-find cursors index)))))
 
 (defmethod initialize-instance :after ((cursor right-sticky-flexicursor)
-				       &rest initargs)
+				       &rest initargs &key (position 0))
   (declare (ignore initargs))
   (with-slots (index chain) cursor
-     (setf index (position-index chain 0))
+     (setf index (position-index chain position))
      (with-slots (cursors) chain
 	(push (make-wp cursor) (skiplist-find cursors index)))))
 
 (defmethod clone-cursor ((cursor standard-flexicursor))
-  (with-slots (index) cursor
-     (let ((result (make-instance (class-of cursor)
-		      :chain (chain cursor))))
-       (setf (slot-value result 'index) index)
-       (with-slots (cursors) (chain cursor)
-	  (push (make-wp result) (skiplist-find cursors index)))
-       result)))
+  (make-instance (class-of cursor)
+     :chain (chain cursor)
+     :position (cursor-pos cursor)))
 
 (defmethod cursor-pos ((cursor left-sticky-flexicursor))
   (1+ (index-position (chain cursor) (slot-value cursor 'index))))
@@ -274,7 +270,7 @@
           'at-beginning-error :cursor cursor)
   (element* (chain cursor) (1- (cursor-pos cursor))))
 
-(defmethod (setf element>) (object (cursor standard-flexicursor))
+(defmethod (setf element<) (object (cursor standard-flexicursor))
   (assert (not (at-beginning-p cursor)) ()
           'at-beginning-error :cursor cursor)
   (setf (element* (chain cursor) (1- (cursor-pos cursor)))