January 2008 - flexichain-cvs@common-lisp.net

[flexichain-cvs] CVS update: flexichain/flexichain.asd flexichain/flexichain.lisp
by charmon＠common-lisp.net 31 Jan '08

31 Jan '08

Update of /project/flexichain/cvsroot/flexichain In directory clnet:/tmp/cvs-serv11978 Modified Files: flexichain.asd flexichain.lisp Log Message: flexichain 1.4.1 * remove unnecessary hack that would set data-start to (1+ gap-end) in delete-elements* Date: Thu Jan 31 12:10:58 2008 Author: charmon Index: flexichain/flexichain.asd diff -u flexichain/flexichain.asd:1.6 flexichain/flexichain.asd:1.7 --- flexichain/flexichain.asd:1.6 Sun Jan 27 01:05:37 2008 +++ flexichain/flexichain.asd Thu Jan 31 12:10:58 2008 @@ -23,7 +23,7 @@ ;; for testing. (asdf:defsystem :flexichain :name "flexichain" - :version "1.4" + :version "1.4.1" :components ((:file "flexichain-package") (:file "utilities" :depends-on ("flexichain-package")) (:file "flexichain" :depends-on ("utilities" "flexichain-package")) Index: flexichain/flexichain.lisp diff -u flexichain/flexichain.lisp:1.6 flexichain/flexichain.lisp:1.7 --- flexichain/flexichain.lisp:1.6 Sun Jan 27 01:05:37 2008 +++ flexichain/flexichain.lisp Thu Jan 31 12:10:58 2008 @@ -313,8 +313,7 @@ (t (let ((surplus-elements (- n (- (length buffer) gap-end)))) (fill-gap chain gap-end (length buffer)) (fill-gap chain 0 surplus-elements) - (setf gap-end surplus-elements - data-start (1+ gap-end))))) + (setf gap-end surplus-elements)))) (when (= gap-end (length buffer)) (setf gap-end 0)) (when (and (> (length buffer) (+ min-size 2))

1 0

[flexichain-cvs] CVS update: flexichain/flexichain-package.lisp flexichain/flexichain.asd flexichain/flexichain.lisp flexichain/flexicursor.lisp flexichain/flexirank.lisp flexichain/rtester.lisp flexichain/skiplist.lisp flexichain/stupid.lisp flexichain/tester.lisp
by charmon＠common-lisp.net 27 Jan '08

27 Jan '08

Update of /project/flexichain/cvsroot/flexichain In directory clnet:/tmp/cvs-serv19460 Modified Files: flexichain-package.lisp flexichain.asd flexichain.lisp flexicursor.lisp flexirank.lisp rtester.lisp skiplist.lisp stupid.lisp tester.lisp Log Message: flexichain 1.4 * replaced tabs with spaces * minor indentation and spacing whitespace fixes Date: Sun Jan 27 01:05:37 2008 Author: charmon Index: flexichain/flexichain-package.lisp diff -u flexichain/flexichain-package.lisp:1.2 flexichain/flexichain-package.lisp:1.3 --- flexichain/flexichain-package.lisp:1.2 Fri Jan 25 18:59:21 2008 +++ flexichain/flexichain-package.lisp Sun Jan 27 01:05:37 2008 @@ -22,22 +22,22 @@ (defpackage :flexichain (:use :common-lisp) (:export #:flexichain #:standard-flexichain - #:flexi-error #:flexi-initialization-error - #:flexi-position-error #:flexi-incompatible-type-error - #:nb-elements #:flexi-empty-p - #:insert* #:insert-vector* #:element* #:delete* #:delete-elements* - #:push-start #:pop-start #:push-end #:pop-end #:rotate + #:flexi-error #:flexi-initialization-error + #:flexi-position-error #:flexi-incompatible-type-error + #:nb-elements #:flexi-empty-p + #:insert* #:insert-vector* #:element* #:delete* #:delete-elements* + #:push-start #:pop-start #:push-end #:pop-end #:rotate #:cursorchain #:standard-cursorchain - #:flexicursor #:standard-flexicursor - #:left-sticky-flexicursor #:right-sticky-flexicursor - #:chain + #:flexicursor #:standard-flexicursor + #:left-sticky-flexicursor #:right-sticky-flexicursor + #:chain #:clone-cursor #:cursor-pos #:at-beginning-error #:at-end-error - #:at-beginning-p #:at-end-p - #:move> #:move< - #:insert #:insert-sequence - #:element< #:element> #:delete< #:delete> - #:flexirank-mixin #:element-rank-mixin #:rank - #:flexi-first-p #:flexi-last-p - #:flexi-next #:flexi-prev)) + #:at-beginning-p #:at-end-p + #:move> #:move< + #:insert #:insert-sequence + #:element< #:element> #:delete< #:delete> + #:flexirank-mixin #:element-rank-mixin #:rank + #:flexi-first-p #:flexi-last-p + #:flexi-next #:flexi-prev)) Index: flexichain/flexichain.asd diff -u flexichain/flexichain.asd:1.5 flexichain/flexichain.asd:1.6 --- flexichain/flexichain.asd:1.5 Fri Jan 25 18:59:21 2008 +++ flexichain/flexichain.asd Sun Jan 27 01:05:37 2008 @@ -23,7 +23,7 @@ ;; for testing. (asdf:defsystem :flexichain :name "flexichain" - :version "1.3" + :version "1.4" :components ((:file "flexichain-package") (:file "utilities" :depends-on ("flexichain-package")) (:file "flexichain" :depends-on ("utilities" "flexichain-package")) Index: flexichain/flexichain.lisp diff -u flexichain/flexichain.lisp:1.5 flexichain/flexichain.lisp:1.6 --- flexichain/flexichain.lisp:1.5 Sat Jan 26 06:23:09 2008 +++ flexichain/flexichain.lisp Sun Jan 27 01:05:37 2008 @@ -157,7 +157,7 @@ (defun required-space (chain nb-elements) (with-slots (min-size expand-factor) chain (+ 2 (max (ceiling (* nb-elements expand-factor)) - min-size)))) + min-size)))) (defmethod initialize-instance :after ((chain standard-flexichain) &rest initargs @@ -182,10 +182,10 @@ (let* ((data-length (if (> (length initial-contents) initial-nb-elements) (length initial-contents) initial-nb-elements)) - (size (required-space chain data-length)) - (fill-size (- size data-length 2)) - (sentinel-list (make-list 2 :initial-element fill-element)) - (fill-list (make-list fill-size :initial-element fill-element))) + (size (required-space chain data-length)) + (fill-size (- size data-length 2)) + (sentinel-list (make-list 2 :initial-element fill-element)) + (fill-list (make-list fill-size :initial-element fill-element))) (setf buffer (if initial-contents (make-array size @@ -209,10 +209,10 @@ (defmacro with-virtual-gap ((bl ds gs ge) chain &body body) (let ((c (gensym))) `(let* ((,c ,chain) - (,bl (length (slot-value ,c 'buffer))) - (,ds (slot-value ,c 'data-start)) - (,gs (slot-value ,c 'gap-start)) - (,ge (slot-value ,c 'gap-end))) + (,bl (length (slot-value ,c 'buffer))) + (,ds (slot-value ,c 'data-start)) + (,gs (slot-value ,c 'gap-start)) + (,ge (slot-value ,c 'gap-end))) (declare (ignorable ,bl ,ds ,gs ,ge)) (when (< ,gs ,ds) (incf ,gs ,bl)) (when (< ,ge ,ds) (incf ,ge ,bl)) @@ -231,9 +231,9 @@ (with-virtual-gap (bl ds gs ge) chain (let ((index (+ ds position 1))) (when (>= index gs) - (incf index (- ge gs))) + (incf index (- ge gs))) (when (>= index bl) - (decf index bl)) + (decf index bl)) index))) (defun index-position (chain index) @@ -258,9 +258,9 @@ (defmethod insert* ((chain standard-flexichain) position object) (with-slots (element-type buffer gap-start) chain (assert (<= 0 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (assert (typep object element-type) () - 'flexi-incompatible-type-error :element object :chain chain) + 'flexi-incompatible-type-error :element object :chain chain) (ensure-gap-position chain position) (ensure-room chain (1+ (nb-elements chain))) (setf (aref buffer gap-start) object) @@ -271,16 +271,16 @@ (defmethod insert-vector* ((chain standard-flexichain) position vector) (with-slots (element-type buffer gap-start) chain (assert (<= 0 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) - (assert (subtypep (array-element-type vector) element-type) () - 'flexi-incompatible-type-error :element vector :chain chain) + 'flexi-position-error :chain chain :position position) + (assert (subtypep (array-element-type vector) element-type) () + 'flexi-incompatible-type-error :element vector :chain chain) (ensure-gap-position chain position) (ensure-room chain (+ (nb-elements chain) (length vector))) (loop for elem across vector - do (setf (aref buffer gap-start) elem) - (incf gap-start) - (when (= gap-start (length buffer)) - (setf gap-start 0))))) + do (setf (aref buffer gap-start) elem) + (incf gap-start) + (when (= gap-start (length buffer)) + (setf gap-start 0))))) (defmethod delete* ((chain standard-flexichain) position) (with-slots (buffer expand-factor min-size fill-element gap-end) chain @@ -292,7 +292,7 @@ (when (= gap-end (length buffer)) (setf gap-end 0)) (when (and (> (length buffer) (+ min-size 2)) - (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor)))) + (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor)))) (decrease-buffer-size chain)))) (defmethod delete-elements* ((chain standard-flexichain) position n) @@ -324,15 +324,15 @@ (defmethod element* ((chain standard-flexichain) position) (with-slots (buffer) chain (assert (< -1 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (aref buffer (position-index chain position)))) (defmethod (setf element*) (object (chain standard-flexichain) position) (with-slots (buffer element-type) chain (assert (< -1 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (assert (typep object element-type) () - 'flexi-incompatible-type-error :chain chain :element object) + 'flexi-incompatible-type-error :chain chain :element object) (setf (aref buffer (position-index chain position)) object))) (defmethod push-start ((chain standard-flexichain) object) @@ -342,19 +342,21 @@ (insert* chain (nb-elements chain) object)) (defmethod pop-start ((chain standard-flexichain)) - (prog1 (element* chain 0) - (delete* chain 0))) + (prog1 + (element* chain 0) + (delete* chain 0))) (defmethod pop-end ((chain standard-flexichain)) (let ((position (1- (nb-elements chain)))) - (prog1 (element* chain position) - (delete* chain position)))) + (prog1 + (element* chain position) + (delete* chain position)))) (defmethod rotate ((chain standard-flexichain) &optional (n 1)) (when (> (nb-elements chain) 1) (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain)))) - ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain)))) - (t nil)))) + ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain)))) + (t nil)))) (defun move-gap (chain hot-spot) "Moves the elements and gap inside the buffer so that @@ -474,7 +476,7 @@ (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) + (- rotated-gap-end count) (- gap-start count) gap-start) (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count))) (decf gap-start count) (setf gap-end (- rotated-gap-end count)) @@ -488,7 +490,7 @@ (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) + (- gap-end count) (- rotated-gap-start count) rotated-gap-start) (fill-gap chain (- rotated-gap-start count) rotated-gap-start) (setf gap-start (- rotated-gap-start count)) (decf gap-end count) Index: flexichain/flexicursor.lisp diff -u flexichain/flexicursor.lisp:1.4 flexichain/flexicursor.lisp:1.5 --- flexichain/flexicursor.lisp:1.4 Sat Jan 26 06:23:09 2008 +++ flexichain/flexicursor.lisp Sun Jan 27 01:05:37 2008 @@ -110,20 +110,20 @@ (defclass right-sticky-flexicursor (standard-flexicursor) ()) (defmethod initialize-instance :after ((cursor left-sticky-flexicursor) - &rest initargs &key (position 0)) + &rest initargs &key (position 0)) (declare (ignore initargs)) (with-slots (index chain) cursor (setf index (position-index chain (1- position))) (with-slots (cursors) chain - (push (make-weak-pointer cursor) cursors)))) + (push (make-weak-pointer cursor) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-flexicursor) - &rest initargs &key (position 0)) + &rest initargs &key (position 0)) (declare (ignore initargs)) (with-slots (index chain) cursor (setf index (position-index chain position)) (with-slots (cursors) chain - (push (make-weak-pointer cursor) cursors)))) + (push (make-weak-pointer cursor) cursors)))) (defun adjust-cursors (cursors start end increment) (let ((acc '())) @@ -131,18 +131,18 @@ for cursor = (and cursors (weak-pointer-value (car cursors))) while cursors do (cond ((null cursor) - (pop cursors)) - ((<= start (flexicursor-index cursor) end) - (incf (flexicursor-index cursor) 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))))) + (pop cursors)) + ((<= start (flexicursor-index cursor) end) + (incf (flexicursor-index cursor) 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) @@ -160,7 +160,7 @@ (defmethod (setf cursor-pos) (position (cursor left-sticky-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () - 'flexi-position-error :chain (chain cursor) :position position) + 'flexi-position-error :chain (chain cursor) :position position) (with-slots (chain) cursor (setf (flexicursor-index cursor) (position-index chain (1- position))))) @@ -169,7 +169,7 @@ (defmethod (setf cursor-pos) (position (cursor right-sticky-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () - 'flexi-position-error :chain (chain cursor) :position position) + 'flexi-position-error :chain (chain cursor) :position position) (with-slots (chain) cursor (setf (flexicursor-index cursor) (position-index chain position)))) @@ -185,18 +185,18 @@ (defmethod insert-sequence ((cursor standard-flexicursor) sequence) (map nil (lambda (object) - (insert cursor object)) + (insert cursor object)) sequence)) (defmethod delete* :before ((chain standard-cursorchain) position) (with-slots (cursors) chain (let* ((old-index (position-index chain position))) (loop for cursor-wp in cursors - as cursor = (weak-pointer-value cursor-wp) - 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)))))))) + as cursor = (weak-pointer-value cursor-wp) + 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)))))))) (defmethod delete-elements* :before ((chain standard-cursorchain) position n) (with-slots (cursors) chain @@ -218,17 +218,17 @@ (let ((chain (chain cursor)) (position (cursor-pos cursor))) (assert (plusp n) () - 'flexi-position-error :chain chain :position n) + 'flexi-position-error :chain chain :position n) (loop repeat n do (delete* chain position)))) (defmethod delete< ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) - (position (cursor-pos cursor))) + (position (cursor-pos cursor))) (assert (plusp n) () - 'flexi-position-error :chain chain :position n) + 'flexi-position-error :chain chain :position n) (loop repeat n - do (delete* chain (- position n))))) + do (delete* chain (- position n))))) (defmethod element> ((cursor standard-flexicursor)) (assert (not (at-end-p cursor)) () Index: flexichain/flexirank.lisp diff -u flexichain/flexirank.lisp:1.3 flexichain/flexirank.lisp:1.4 --- flexichain/flexirank.lisp:1.3 Tue Oct 17 12:02:02 2006 +++ flexichain/flexirank.lisp Sun Jan 27 01:05:37 2008 @@ -60,21 +60,21 @@ (defmethod move-elements :before ((chain flexirank-mixin) to from start1 start2 end2) (declare (ignore to)) (loop for old from start2 below end2 - for new from start1 - do (let ((element (aref from old))) - (when (typep element 'element-rank-mixin) - (setf (index element) new))))) + for new from start1 + do (let ((element (aref from old))) + (when (typep element 'element-rank-mixin) + (setf (index element) new))))) (defmethod insert* :after ((chain flexirank-mixin) position (object element-rank-mixin)) (setf (index object) (position-index chain position) - (chain object) chain)) + (chain object) chain)) (defmethod (setf element*) :after ((object element-rank-mixin) (chain flexirank-mixin) position) (setf (index object) (position-index chain position) - (chain object) chain)) + (chain object) chain)) (defmethod insert-vector* :after ((chain flexirank-mixin) position vector) (loop for elem across vector - for pos from position - do (setf (index elem) (position-index chain pos) - (chain elem) chain))) + for pos from position + do (setf (index elem) (position-index chain pos) + (chain elem) chain))) Index: flexichain/rtester.lisp diff -u flexichain/rtester.lisp:1.1.1.1 flexichain/rtester.lisp:1.2 --- flexichain/rtester.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006 +++ flexichain/rtester.lisp Sun Jan 27 01:05:37 2008 @@ -40,30 +40,30 @@ (defun compare () ;; check that they are the same length (assert (= (flexichain:nb-elements *fc-real*) - (stupid:nb-elements *fc-fake*))) + (stupid:nb-elements *fc-fake*))) ;; check that they have the same elements in the same places (loop for pos from 0 below (flexichain:nb-elements *fc-real*) - do (assert (= (flexichain:element* *fc-real* pos) - (stupid:element* *fc-fake* pos)))) + do (assert (= (flexichain:element* *fc-real* pos) + (stupid:element* *fc-fake* pos)))) ;; check all the cursors (loop for x in *cursors-real* - for y in *cursors-fake* - do (assert (= (flexichain:cursor-pos x) - (stupid:cursor-pos y))) - (unless (zerop (flexichain:cursor-pos x)) - (assert (= (flexichain:element< x) - (stupid:element< y)))) - (unless (= (flexichain:cursor-pos x) - (flexichain:nb-elements *fc-real*)) - (assert (= (flexichain:element> x) - (stupid:element> y)))))) + for y in *cursors-fake* + do (assert (= (flexichain:cursor-pos x) + (stupid:cursor-pos y))) + (unless (zerop (flexichain:cursor-pos x)) + (assert (= (flexichain:element< x) + (stupid:element< y)))) + (unless (= (flexichain:cursor-pos x) + (flexichain:nb-elements *fc-real*)) + (assert (= (flexichain:element> x) + (stupid:element> y)))))) (defun add-inst (inst) (push inst *instructions*)) (defun i* (&optional - (pos (random (1+ (stupid:nb-elements *fc-fake*)))) - (elem (random 1000000))) + (pos (random (1+ (stupid:nb-elements *fc-fake*)))) + (elem (random 1000000))) (add-inst `(i* ,pos ,elem)) (flexichain:insert* *fc-real* pos elem) (stupid:insert* *fc-fake* pos elem)) @@ -80,7 +80,7 @@ (unless (zerop (stupid:nb-elements *fc-fake*)) (unless pos (setf pos (random (stupid:nb-elements *fc-fake*)) - elem (random 1000000))) + elem (random 1000000))) (add-inst `(se* ,pos ,elem)) (setf (flexichain:element* *fc-real* pos) elem) (setf (stupid:element* *fc-fake* pos) elem))) @@ -88,16 +88,16 @@ (defun mlc () (add-inst `(mlc)) (push (make-instance 'flexichain:left-sticky-flexicursor :chain *fc-real*) - *cursors-real*) + *cursors-real*) (push (make-instance 'stupid:left-sticky-flexicursor :chain *fc-fake*) - *cursors-fake*)) + *cursors-fake*)) (defun mrc () (add-inst `(mrc)) (push (make-instance 'flexichain:right-sticky-flexicursor :chain *fc-real*) - *cursors-real*) + *cursors-real*) (push (make-instance 'stupid:right-sticky-flexicursor :chain *fc-fake*) - *cursors-fake*)) + *cursors-fake*)) (defun cc (&optional (elt (random (length *cursors-real*)))) @@ -106,15 +106,15 @@ (push (stupid:clone-cursor (elt *cursors-fake* elt)) *cursors-fake*)) (defun scp (&optional - (elt (random (length *cursors-real*))) - (pos (random (1+ (flexichain:nb-elements *fc-real*))))) + (elt (random (length *cursors-real*))) + (pos (random (1+ (flexichain:nb-elements *fc-real*))))) (add-inst `(scp ,elt ,pos)) (setf (flexichain:cursor-pos (elt *cursors-real* elt)) pos) (setf (stupid:cursor-pos (elt *cursors-fake* elt)) pos)) (defun ii (&optional - (elt (random (length *cursors-fake*))) - (elem (random 1000000))) + (elt (random (length *cursors-fake*))) + (elem (random 1000000))) (add-inst `(ii ,elt ,elem)) (flexichain:insert (elt *cursors-real* elt) elem) (stupid:insert (elt *cursors-fake* elt) elem)) @@ -127,24 +127,24 @@ (defun d> (&optional (elt (random (length *cursors-fake*)))) (unless (= (stupid:cursor-pos (elt *cursors-fake* elt)) - (stupid:nb-elements (stupid:chain (elt *cursors-fake* elt)))) + (stupid:nb-elements (stupid:chain (elt *cursors-fake* elt)))) (add-inst `(d> ,elt)) (flexichain:delete> (elt *cursors-real* elt)) (stupid:delete> (elt *cursors-fake* elt)))) (defun s< (&optional - (elt (random (length *cursors-real*))) - (elem (random 1000000))) + (elt (random (length *cursors-real*))) + (elem (random 1000000))) (unless (zerop (stupid:cursor-pos (elt *cursors-fake* elt))) (add-inst `(s< ,elt ,elem)) (setf (flexichain:element< (elt *cursors-real* elt)) elem) (setf (stupid:element< (elt *cursors-fake* elt)) elem))) (defun s> (&optional - (elt (random (length *cursors-real*))) - (elem (random 1000000))) + (elt (random (length *cursors-real*))) + (elem (random 1000000))) (unless (= (stupid:cursor-pos (elt *cursors-fake* elt)) - (stupid:nb-elements (stupid:chain (elt *cursors-fake* elt)))) + (stupid:nb-elements (stupid:chain (elt *cursors-fake* elt)))) (add-inst `(s> ,elt ,elem)) (setf (flexichain:element> (elt *cursors-real* elt)) elem) (setf (stupid:element> (elt *cursors-fake* elt)) elem))) @@ -152,8 +152,8 @@ (defmacro randomcase (&body clauses) `(ecase (random ,(length clauses)) ,@(loop for clause in clauses - for i from 0 - collect `(,i ,clause)))) + for i from 0 + collect `(,i ,clause)))) (defun i-or-d () (if *ins-del-state* @@ -185,11 +185,11 @@ (mlc) (mrc) (loop repeat n - do (test-step))) + do (test-step))) (defun replay (instructions) (let ((*instructions* '())) (reset-all) (loop for inst in (reverse instructions) - do (apply (car inst) (cdr inst)) - (compare)))) + do (apply (car inst) (cdr inst)) + (compare)))) Index: flexichain/skiplist.lisp diff -u flexichain/skiplist.lisp:1.1.1.1 flexichain/skiplist.lisp:1.2 --- flexichain/skiplist.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006 +++ flexichain/skiplist.lisp Sun Jan 27 01:05:37 2008 @@ -35,11 +35,11 @@ (print-unreadable-object (s stream :type t) (with-slots (start) s (when (entry-next start 0) - (loop for entry = (entry-next start 0) then (entry-next entry 0) - do (format stream "(~W ~W) " - (entry-key entry) - (entry-obj entry)) - until (last-entry-p start entry 0)))))) + (loop for entry = (entry-next start 0) then (entry-next entry 0) + do (format stream "(~W ~W) " + (entry-key entry) + (entry-obj entry)) + until (last-entry-p start entry 0)))))) (defun entry-obj (entry) (aref entry 0)) @@ -88,18 +88,18 @@ (defun find-entry-level (skiplist entry level key) (with-slots (start) skiplist (loop until (or (key-= skiplist (entry-key (entry-next entry level)) key) - (and (key-< skiplist (entry-key entry) key) - (key-> skiplist (entry-key (entry-next entry level)) key)) - (and (key-< skiplist (entry-key entry) key) - (key-< skiplist (entry-key (entry-next entry level)) key) - (last-entry-p start entry level) - (eq (entry-next entry level) (entry-next start level))) - (and (key-> skiplist (entry-key entry) key) - (key-> skiplist (entry-key (entry-next entry level)) key) - (last-entry-p start entry level))) - do (setf entry (entry-next entry level)))) + (and (key-< skiplist (entry-key entry) key) + (key-> skiplist (entry-key (entry-next entry level)) key)) + (and (key-< skiplist (entry-key entry) key) + (key-< skiplist (entry-key (entry-next entry level)) key) + (last-entry-p start entry level) + (eq (entry-next entry level) (entry-next start level))) + (and (key-> skiplist (entry-key entry) key) + (key-> skiplist (entry-key (entry-next entry level)) key) + (last-entry-p start entry level))) + do (setf entry (entry-next entry level)))) entry) - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -111,10 +111,10 @@ (with-slots (current-maxlevel start) skiplist (let ((entry (entry-next start current-maxlevel))) (loop for l downfrom current-maxlevel to 0 - do (setf entry (find-entry-level skiplist entry l key))) + do (setf entry (find-entry-level skiplist entry l key))) (if (key-= skiplist (entry-key (entry-next entry 0)) key) - (values (entry-obj (entry-next entry 0)) t) - (values nil nil))))) + (values (entry-obj (entry-next entry 0)) t) + (values nil nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -124,7 +124,7 @@ (assert (not (skiplist-empty-p skiplist))) (with-slots (start) skiplist (values (entry-obj (entry-next start 0)) - (entry-key (entry-next start 0))))) + (entry-key (entry-next start 0))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -132,37 +132,37 @@ (defun pick-a-level (maxlevel) (loop for level from 0 to maxlevel - while (zerop (random 2)) - finally (return level))) + while (zerop (random 2)) + finally (return level))) (defun make-entry (level key obj) (let ((entry (make-array (+ level 3) :initial-element nil))) (setf (aref entry 0) obj - (aref entry 1) key) + (aref entry 1) key) entry)) (defun (setf skiplist-find) (obj skiplist key) (with-slots (current-maxlevel start) skiplist (if (second (multiple-value-list (skiplist-find skiplist key))) - (let ((entry (entry-next start current-maxlevel))) - (loop for l downfrom current-maxlevel to 0 - do (setf entry (find-entry-level skiplist entry l key))) - (setf (entry-obj (entry-next entry 0)) obj)) - (let* ((level (pick-a-level (maxlevel skiplist))) - (new-entry (make-entry level key obj))) - (loop for l downfrom level above current-maxlevel - do (setf (entry-next start l) new-entry - (entry-next new-entry l) new-entry)) - (let ((entry (entry-next start current-maxlevel))) - (loop for l downfrom current-maxlevel above level - do (setf entry (find-entry-level skiplist entry l key))) - (loop for l downfrom (min level current-maxlevel) to 0 - do (setf entry (find-entry-level skiplist entry l key)) - (setf (entry-next new-entry l) (entry-next entry l) - (entry-next entry l) new-entry) - (when (key-< skiplist key (entry-key entry)) - (setf (entry-next start l) new-entry)))) - (setf current-maxlevel (max current-maxlevel level))))) + (let ((entry (entry-next start current-maxlevel))) + (loop for l downfrom current-maxlevel to 0 + do (setf entry (find-entry-level skiplist entry l key))) + (setf (entry-obj (entry-next entry 0)) obj)) + (let* ((level (pick-a-level (maxlevel skiplist))) + (new-entry (make-entry level key obj))) + (loop for l downfrom level above current-maxlevel + do (setf (entry-next start l) new-entry + (entry-next new-entry l) new-entry)) + (let ((entry (entry-next start current-maxlevel))) + (loop for l downfrom current-maxlevel above level + do (setf entry (find-entry-level skiplist entry l key))) + (loop for l downfrom (min level current-maxlevel) to 0 + do (setf entry (find-entry-level skiplist entry l key)) + (setf (entry-next new-entry l) (entry-next entry l) + (entry-next entry l) new-entry) + (when (key-< skiplist key (entry-key entry)) + (setf (entry-next start l) new-entry)))) + (setf current-maxlevel (max current-maxlevel level))))) skiplist) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -174,20 +174,20 @@ (with-slots (current-maxlevel start) skiplist (let ((entry (entry-next start current-maxlevel))) (loop for l downfrom current-maxlevel to 0 - do (setf entry (find-entry-level skiplist entry l key)) - when (key-= skiplist (entry-key (entry-next entry l)) key) - do (cond ((key-= skiplist (entry-key entry) key) - (setf (entry-next start l) nil)) - ((key-< skiplist (entry-key entry) key) - (setf (entry-next entry l) - (entry-next (entry-next entry l) l))) - (t (setf (entry-next entry l) - (entry-next (entry-next entry l) l)) - (setf (entry-next start l) - (entry-next entry l))))) + do (setf entry (find-entry-level skiplist entry l key)) + when (key-= skiplist (entry-key (entry-next entry l)) key) + do (cond ((key-= skiplist (entry-key entry) key) + (setf (entry-next start l) nil)) + ((key-< skiplist (entry-key entry) key) + (setf (entry-next entry l) + (entry-next (entry-next entry l) l))) + (t (setf (entry-next entry l) + (entry-next (entry-next entry l) l)) + (setf (entry-next start l) + (entry-next entry l))))) (loop while (and (null (entry-next start current-maxlevel)) - (>= current-maxlevel 0)) - do (decf current-maxlevel)))) + (>= current-maxlevel 0)) + do (decf current-maxlevel)))) skiplist) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -197,21 +197,21 @@ (defun update-interval (skiplist entry to update-key) (with-slots (start) skiplist (flet ((update-entry (entry) - (setf (entry-key entry) - (funcall update-key (entry-key entry) (entry-obj entry))))) + (setf (entry-key entry) + (funcall update-key (entry-key entry) (entry-obj entry))))) (loop while (key-<= skiplist (entry-key entry) to) - do (update-entry entry) - until (last-entry-p start entry 0) - do (setf entry (entry-next entry 0)))))) + do (update-entry entry) + until (last-entry-p start entry 0) + do (setf entry (entry-next entry 0)))))) (defun skiplist-slide-keys (skiplist from to update-key) (unless (skiplist-empty-p skiplist) (with-slots (current-maxlevel start) skiplist (let ((entry (entry-next start current-maxlevel))) - (loop for l downfrom current-maxlevel to 0 - do (setf entry (find-entry-level skiplist entry l from))) - (when (key->= skiplist (entry-key (entry-next entry 0)) from) - (update-interval skiplist (entry-next entry 0) to update-key))))) + (loop for l downfrom current-maxlevel to 0 + do (setf entry (find-entry-level skiplist entry l from))) + (when (key->= skiplist (entry-key (entry-next entry 0)) from) + (update-interval skiplist (entry-next entry 0) to update-key))))) skiplist) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -222,22 +222,22 @@ (unless (skiplist-empty-p skiplist) (with-slots (current-maxlevel start) skiplist (let ((entry (entry-next start current-maxlevel))) - (loop for l downfrom current-maxlevel to 0 - do (setf entry (find-entry-level skiplist entry l to))) - (when (key-= skiplist (entry-key (entry-next entry 0)) to) - (setf entry (entry-next entry 0))) - (cond ((and (key-> skiplist (entry-key entry) to) - (key-> skiplist (entry-key (entry-next entry 0)) to)) - nil) - ((and (key-<= skiplist (entry-key entry) to) - (key-<= skiplist (entry-key (entry-next entry 0)) to)) - (update-interval skiplist (entry-next entry 0) to update-key)) - (t (update-interval skiplist (entry-next start 0) to update-key) - (loop with entry = (entry-next entry 0) - for level from 0 to current-maxlevel - do (loop until (>= (length entry) (+ 3 level)) - do (setf entry (entry-next entry (1- level)))) - (setf (entry-next start level) entry))))))) + (loop for l downfrom current-maxlevel to 0 + do (setf entry (find-entry-level skiplist entry l to))) + (when (key-= skiplist (entry-key (entry-next entry 0)) to) + (setf entry (entry-next entry 0))) + (cond ((and (key-> skiplist (entry-key entry) to) + (key-> skiplist (entry-key (entry-next entry 0)) to)) + nil) + ((and (key-<= skiplist (entry-key entry) to) + (key-<= skiplist (entry-key (entry-next entry 0)) to)) + (update-interval skiplist (entry-next entry 0) to update-key)) + (t (update-interval skiplist (entry-next start 0) to update-key) + (loop with entry = (entry-next entry 0) + for level from 0 to current-maxlevel + do (loop until (>= (length entry) (+ 3 level)) + do (setf entry (entry-next entry (1- level)))) + (setf (entry-next start level) entry))))))) skiplist) @@ -248,28 +248,28 @@ (defun update-interval-to-end (skiplist entry update-key) (with-slots (start) skiplist (flet ((update-entry (entry) - (setf (entry-key entry) - (funcall update-key (entry-key entry) (entry-obj entry))))) + (setf (entry-key entry) + (funcall update-key (entry-key entry) (entry-obj entry))))) (loop do (update-entry entry) - until (last-entry-p start entry 0) - do (setf entry (entry-next entry 0)))))) + until (last-entry-p start entry 0) + do (setf entry (entry-next entry 0)))))) (defun skiplist-rotate-suffix (skiplist from update-key) (unless (skiplist-empty-p skiplist) (with-slots (current-maxlevel start) skiplist (let ((entry (entry-next start current-maxlevel))) - (loop for l downfrom current-maxlevel to 0 - do (setf entry (find-entry-level skiplist entry l from))) - (cond ((and (key-< skiplist (entry-key entry) from) - (key-< skiplist (entry-key (entry-next entry 0)) from)) - nil) - ((and (key->= skiplist (entry-key entry) from) - (key->= skiplist (entry-key (entry-next entry 0)) from)) - (update-interval-to-end skiplist (entry-next entry 0) update-key)) - (t (update-interval-to-end skiplist (entry-next entry 0) update-key) - (loop with entry = (entry-next entry 0) - for level from 0 to current-maxlevel - do (loop until (>= (length entry) (+ 3 level)) - do (setf entry (entry-next entry (1- level)))) - (setf (entry-next start level) entry))))))) + (loop for l downfrom current-maxlevel to 0 + do (setf entry (find-entry-level skiplist entry l from))) + (cond ((and (key-< skiplist (entry-key entry) from) + (key-< skiplist (entry-key (entry-next entry 0)) from)) + nil) + ((and (key->= skiplist (entry-key entry) from) + (key->= skiplist (entry-key (entry-next entry 0)) from)) + (update-interval-to-end skiplist (entry-next entry 0) update-key)) + (t (update-interval-to-end skiplist (entry-next entry 0) update-key) + (loop with entry = (entry-next entry 0) + for level from 0 to current-maxlevel + do (loop until (>= (length entry) (+ 3 level)) + do (setf entry (entry-next entry (1- level)))) + (setf (entry-next start level) entry))))))) skiplist) Index: flexichain/stupid.lisp diff -u flexichain/stupid.lisp:1.1.1.1 flexichain/stupid.lisp:1.2 --- flexichain/stupid.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006 +++ flexichain/stupid.lisp Sun Jan 27 01:05:37 2008 @@ -6,21 +6,21 @@ (defpackage :stupid (:use :common-lisp) (:export #:flexichain #:standard-flexichain - #:flexi-error #:flexi-initialization-error - #:flexi-position-error #:flexi-incompatible-type-error - #:nb-elements #:flexi-empty-p - #:insert* #:element* #:delete* - #:push-start #:pop-start #:push-end #:pop-end #:rotate + #:flexi-error #:flexi-initialization-error + #:flexi-position-error #:flexi-incompatible-type-error + #:nb-elements #:flexi-empty-p + #:insert* #:element* #:delete* + #:push-start #:pop-start #:push-end #:pop-end #:rotate #:cursorchain #:standard-cursorchain - #:flexicursor #:standard-flexicursor - #:left-sticky-flexicursor #:right-sticky-flexicursor - #:chain + #:flexicursor #:standard-flexicursor + #:left-sticky-flexicursor #:right-sticky-flexicursor + #:chain #:clone-cursor #:cursor-pos #:at-beginning-error #:at-end-error - #:at-beginning-p #:at-end-p - #:move> #:move< - #:insert #:insert-sequence - #:element< #:element> #:delete< #:delete>)) + #:at-beginning-p #:at-end-p + #:move> #:move< + #:insert #:insert-sequence + #:element< #:element> #:delete< #:delete>)) (in-package :stupid) @@ -118,17 +118,17 @@ (defmethod insert* ((chain standard-flexichain) position object) (assert (<= 0 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (let* ((remainder (nthcdr (* 2 position) (elements chain)))) (push (remove-if-not (lambda (x) (typep x 'right-sticky-flexicursor)) (car remainder)) - (cdr remainder)) + (cdr remainder)) (push object (cdr remainder)) (setf (car remainder) - (remove-if (lambda (x) (typep x 'right-sticky-flexicursor)) (car remainder))))) + (remove-if (lambda (x) (typep x 'right-sticky-flexicursor)) (car remainder))))) (defmethod delete* ((chain standard-flexichain) position) (assert (< -1 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (let* ((remainder (nthcdr (* 2 position) (elements chain)))) (pop (cdr remainder)) (setf (car remainder) (append (cadr remainder) (car remainder))) @@ -136,12 +136,12 @@ (defmethod element* ((chain standard-flexichain) position) (assert (< -1 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (nth (1+ (* 2 position)) (elements chain))) (defmethod (setf element*) (object (chain standard-flexichain) position) (assert (< -1 position (nb-elements chain)) () - 'flexi-position-error :chain chain :position position) + 'flexi-position-error :chain chain :position position) (setf (nth (1+ (* 2 position)) (elements chain)) object)) (defmethod push-start ((chain standard-flexichain) object) @@ -152,18 +152,18 @@ (defmethod pop-start ((chain standard-flexichain)) (prog1 (element* chain 0) - (delete* chain 0))) + (delete* chain 0))) (defmethod pop-end ((chain standard-flexichain)) (let ((position (1- (nb-elements chain)))) (prog1 (element* chain position) - (delete* chain position)))) + (delete* chain position)))) (defmethod rotate ((chain standard-flexichain) &optional (n 1)) (when (> (nb-elements chain) 1) (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain)))) - ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain)))) - (t nil)))) + ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain)))) + (t nil)))) (defclass cursorchain (flexichain) () @@ -249,7 +249,7 @@ (:documentation "The standard instantiable subclass of FLEXICURSOR")) (defmethod initialize-instance :after ((cursor standard-flexicursor) - &rest args &key (position 0)) + &rest args &key (position 0)) (declare (ignore args)) (push cursor (car (nthcdr (* 2 position) (elements (chain cursor)))))) @@ -259,9 +259,9 @@ (defmethod cursor-pos ((cursor standard-flexicursor)) (loop for sublist on (elements (chain cursor)) by #'cddr - for pos from 0 - when (member cursor (car sublist) :test #'eq) - do (return pos))) + for pos from 0 + when (member cursor (car sublist) :test #'eq) + do (return pos))) (defun sublist-of-cursor (cursor) (nthcdr (* 2 (cursor-pos cursor)) (elements (chain cursor)))) @@ -273,9 +273,9 @@ (defmethod (setf cursor-pos) (position (cursor standard-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () - 'flexi-position-error :chain (chain cursor) :position position) + 'flexi-position-error :chain (chain cursor) :position position) (let ((sublist1 (sublist-of-cursor cursor)) - (sublist2 (nthcdr (* 2 position) (elements (chain cursor))))) + (sublist2 (nthcdr (* 2 position) (elements (chain cursor))))) (setf (car sublist1) (remove cursor (car sublist1) :test #'eq)) (push cursor (car sublist2)))) @@ -297,24 +297,24 @@ (defmethod insert-sequence ((cursor standard-flexicursor) sequence) (map nil (lambda (object) - (insert cursor object)) + (insert cursor object)) sequence)) (defmethod delete> ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) (position (cursor-pos cursor))) (assert (plusp n) () - 'flexi-position-error :chain chain :position n) + 'flexi-position-error :chain chain :position n) (loop repeat n do (delete* chain position)))) (defmethod delete< ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) - (position (cursor-pos cursor))) + (position (cursor-pos cursor))) (assert (plusp n) () - 'flexi-position-error :chain chain :position n) + 'flexi-position-error :chain chain :position n) (loop repeat n - do (delete* chain (- position n))))) + do (delete* chain (- position n))))) (defmethod element> ((cursor standard-flexicursor)) (assert (not (at-end-p cursor)) () Index: flexichain/tester.lisp diff -u flexichain/tester.lisp:1.1.1.1 flexichain/tester.lisp:1.2 --- flexichain/tester.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006 +++ flexichain/tester.lisp Sun Jan 27 01:05:37 2008 @@ -2,9 +2,9 @@ (define-application-frame tester () ((chain :initform (make-instance 'standard-cursorchain - :element-type 'character - :fill-element #\_) - :reader chain) + :element-type 'character + :fill-element #\_) + :reader chain) (cursors :initform (make-array 2) :reader cursors)) (:panes (app :application :width 800 :height 300 :display-function 'display-app) @@ -15,67 +15,67 @@ (declare (ignore args)) (with-slots (chain cursors) frame (setf (aref cursors 0) - (make-instance 'left-sticky-flexicursor :chain chain)) + (make-instance 'left-sticky-flexicursor :chain chain)) (setf (aref cursors 1) - (make-instance 'right-sticky-flexicursor :chain chain)))) + (make-instance 'right-sticky-flexicursor :chain chain)))) (defun run-tester () (loop for port in climi::*all-ports* - do (destroy-port port)) + do (destroy-port port)) (setq climi::*all-ports* nil) (run-frame-top-level (make-application-frame 'tester))) (defun display-app (frame pane) (let* ((chain (chain frame)) - (buffer (slot-value chain 'flexichain::buffer)) - (length (length buffer)) - (cursors (cursors frame))) + (buffer (slot-value chain 'flexichain::buffer)) + (length (length buffer)) + (cursors (cursors frame))) (format pane "nb elments: ~a~%~%" (nb-elements chain)) (loop for i from 0 below (nb-elements chain) - do (format pane " ~a" (element* chain i))) + do (format pane " ~a" (element* chain i))) (format pane "~%") (loop for i from 0 below 2 - do (format pane (if (minusp (cursor-pos (aref cursors i))) - (make-string (* -2 (cursor-pos (aref cursors i))) - :initial-element #\?) - (make-string (* 2 (cursor-pos (aref cursors i))) - :initial-element #\space))) - (format pane "~a~%" i)) + do (format pane (if (minusp (cursor-pos (aref cursors i))) + (make-string (* -2 (cursor-pos (aref cursors i))) + :initial-element #\?) + (make-string (* 2 (cursor-pos (aref cursors i))) + :initial-element #\space))) + (format pane "~a~%" i)) (format pane "~%~%") (format pane (if (minusp (slot-value chain 'flexichain::gap-start)) - (make-string (* -2 (slot-value chain 'flexichain::gap-start)) - :initial-element #\?) - (make-string (* 2 (slot-value chain 'flexichain::gap-start)) - :initial-element #\space))) + (make-string (* -2 (slot-value chain 'flexichain::gap-start)) + :initial-element #\?) + (make-string (* 2 (slot-value chain 'flexichain::gap-start)) + :initial-element #\space))) (format pane ">~%") (format pane (if (minusp (slot-value chain 'flexichain::gap-end)) - (make-string (* -2 (slot-value chain 'flexichain::gap-end)) - :initial-element #\?) - (make-string (* 2 (slot-value chain 'flexichain::gap-end)) - :initial-element #\space))) + (make-string (* -2 (slot-value chain 'flexichain::gap-end)) + :initial-element #\?) + (make-string (* 2 (slot-value chain 'flexichain::gap-end)) + :initial-element #\space))) (format pane "<~%") (loop for i from 0 below length - do (format pane "~a~a" - (if (= i (slot-value chain 'flexichain::data-start)) - #\* #\Space) - (aref buffer i))) + do (format pane "~a~a" + (if (= i (slot-value chain 'flexichain::data-start)) + #\* #\Space) + (aref buffer i))) (format pane "~%") (loop for i from 0 below 2 - do (format pane (make-string (1+ (* 2 (slot-value (aref cursors i) - 'flexichain::index))) - :initial-element #\space)) - (format pane "~a~a~%" i (at-end-p (aref cursors i)))) + do (format pane (make-string (1+ (* 2 (slot-value (aref cursors i) + 'flexichain::index))) + :initial-element #\space)) + (format pane "~a~a~%" i (at-end-p (aref cursors i)))) (format pane "~%~%"))) (defmethod execute-frame-command :around ((frame tester) command) (declare (ignore command)) (handler-case (call-next-method) (flexi-error (condition) (format (frame-standard-input *application-frame*) - "~a~%" condition)))) + "~a~%" condition)))) (define-tester-command (com-empty :name t) () (format (frame-standard-input *application-frame*) - "~a~%" (flexi-empty-p (chain *application-frame*)))) + "~a~%" (flexi-empty-p (chain *application-frame*)))) (defun to-char (symbol) (char-downcase (aref (symbol-name symbol) 0))) @@ -85,7 +85,7 @@ (define-tester-command (com-element* :name t) ((pos 'integer)) (format (frame-standard-input *application-frame*) - "~a~%" (element* (chain *application-frame*) pos))) + "~a~%" (element* (chain *application-frame*) pos))) (define-tester-command (com-set-element* :name t) ((pos 'integer) (object 'symbol)) (setf (element* (chain *application-frame*) pos) (to-char object))) @@ -101,11 +101,11 @@ (define-tester-command (com-pop-start :name t) () (format (frame-standard-input *application-frame*) - "~a~%" (pop-start (chain *application-frame*)))) + "~a~%" (pop-start (chain *application-frame*)))) (define-tester-command (com-pop-end :name t) () (format (frame-standard-input *application-frame*) - "~a~%" (pop-end (chain *application-frame*)))) + "~a~%" (pop-end (chain *application-frame*)))) (define-tester-command (com-rotate :name t) ((amount 'integer)) (rotate (chain *application-frame*) amount)) @@ -128,11 +128,11 @@ (define-tester-command (com-clear :name t) () (with-slots (chain cursors) *application-frame* (setf chain (make-instance 'standard-cursorchain - :element-type 'character :fill-element #\_)) + :element-type 'character :fill-element #\_)) (setf (aref cursors 0) - (make-instance 'left-sticky-flexicursor :chain chain)) + (make-instance 'left-sticky-flexicursor :chain chain)) (setf (aref cursors 1) - (make-instance 'right-sticky-flexicursor :chain chain)))) + (make-instance 'right-sticky-flexicursor :chain chain)))) (define-tester-command (com-quit :name t) () (frame-exit *application-frame*))

1 0

[flexichain-cvs] CVS update: flexichain/flexichain.lisp flexichain/flexicursor.lisp
by rstrandh＠common-lisp.net 26 Jan '08

26 Jan '08

Update of /project/flexichain/cvsroot/flexichain In directory clnet:/tmp/cvs-serv9793 Modified Files: flexichain.lisp flexicursor.lisp Log Message: Patch from Troels Henriksen. Date: Sat Jan 26 06:23:09 2008 Author: rstrandh Index: flexichain/flexichain.lisp diff -u flexichain/flexichain.lisp:1.4 flexichain/flexichain.lisp:1.5 --- flexichain/flexichain.lisp:1.4 Fri Jan 25 18:59:21 2008 +++ flexichain/flexichain.lisp Sat Jan 26 06:23:09 2008 @@ -297,15 +297,24 @@ (defmethod delete-elements* ((chain standard-flexichain) position n) (unless (zerop n) - (with-slots (buffer expand-factor min-size fill-element gap-end gap-start) chain + (with-slots (buffer expand-factor min-size gap-end data-start) chain (when (minusp n) (incf position n) (setf n (* -1 n))) (assert (<= 0 (+ position n) (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (ensure-gap-position chain position) - (fill-gap chain gap-end (+ gap-end n)) - (incf gap-end n) + ;; Two cases to consider - one where position+n is wholly on + ;; this side of the gap in buffer, and one where part of it is + ;; "wrapped around" to the beginning of buffer. + (cond ((>= (length buffer) (+ gap-end n)) + (fill-gap chain gap-end (+ gap-end n)) + (incf gap-end n)) + (t (let ((surplus-elements (- n (- (length buffer) gap-end)))) + (fill-gap chain gap-end (length buffer)) + (fill-gap chain 0 surplus-elements) + (setf gap-end surplus-elements + data-start (1+ gap-end))))) (when (= gap-end (length buffer)) (setf gap-end 0)) (when (and (> (length buffer) (+ min-size 2)) Index: flexichain/flexicursor.lisp diff -u flexichain/flexicursor.lisp:1.3 flexichain/flexicursor.lisp:1.4 --- flexichain/flexicursor.lisp:1.3 Fri Jan 25 18:59:21 2008 +++ flexichain/flexicursor.lisp Sat Jan 26 06:23:09 2008 @@ -204,17 +204,15 @@ (incf position n) (setf n (* -1 n))) (unless (zerop n) - (let* ((start-index (position-index chain position)) - (end-index (position-index chain (+ position n -1)))) - (loop for cursor-wp in cursors - as cursor = (weak-pointer-value cursor-wp) - when (and cursor (<= start-index (flexicursor-index cursor) - end-index)) - do (typecase cursor - (right-sticky-flexicursor (setf (cursor-pos cursor) - (+ position n))) - (left-sticky-flexicursor (setf (cursor-pos cursor) - position)))))))) + (loop for cursor-wp in cursors + as cursor = (weak-pointer-value cursor-wp) + when (and cursor (<= position (cursor-pos cursor) + (+ position n))) + do (typecase cursor + (right-sticky-flexicursor (setf (cursor-pos cursor) + (+ position n))) + (left-sticky-flexicursor (setf (cursor-pos cursor) + position))))))) (defmethod delete> ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor))

1 0

[flexichain-cvs] CVS update: flexichain/Doc/flexichain.tex
by charmon＠common-lisp.net 25 Jan '08

25 Jan '08

Update of /project/flexichain/cvsroot/flexichain/Doc In directory clnet:/tmp/cvs-serv8302/Doc Modified Files: flexichain.tex Log Message: flexichain 0.3 * Troels Henriksen's changes for flexichain 0.3. ** Added delete-elements* ** minor indentation fixes ** clean up some of cursor-pos methods Date: Fri Jan 25 18:59:23 2008 Author: charmon Index: flexichain/Doc/flexichain.tex diff -u flexichain/Doc/flexichain.tex:1.1.1.1 flexichain/Doc/flexichain.tex:1.2 --- flexichain/Doc/flexichain.tex:1.1.1.1 Wed Feb 8 21:51:06 2006 +++ flexichain/Doc/flexichain.tex Fri Jan 25 18:59:23 2008 @@ -175,6 +175,15 @@ to the length of \arg{chain}), the \cl{flexi-position} condition will be signaled. +\Defgeneric {delete-elements*} {chain position n} + +Delete N elements at \arg{position} of the flexichain. If +$\arg{position}+\arg{N}$ is out of range (less than $0$ or greater +than or equal to the length of \arg{chain}, the +\cl{flexi-position-error} condition will be signaled, and nothing will +be deleted. \arg{n} can be negative, in which case elements will be +deleted before \arg{position}. + \Defgeneric {element*} {chain position} Return the element at \arg{position} of the \arg{chain}. If

1 0

[flexichain-cvs] CVS update: flexichain/flexichain-package.lisp flexichain/flexichain.asd flexichain/flexichain.lisp flexichain/flexicursor.lisp
by charmon＠common-lisp.net 25 Jan '08

25 Jan '08

Update of /project/flexichain/cvsroot/flexichain In directory clnet:/tmp/cvs-serv8302 Modified Files: flexichain-package.lisp flexichain.asd flexichain.lisp flexicursor.lisp Log Message: flexichain 0.3 * Troels Henriksen's changes for flexichain 0.3. ** Added delete-elements* ** minor indentation fixes ** clean up some of cursor-pos methods Date: Fri Jan 25 18:59:21 2008 Author: charmon Index: flexichain/flexichain-package.lisp diff -u flexichain/flexichain-package.lisp:1.1.1.1 flexichain/flexichain-package.lisp:1.2 --- flexichain/flexichain-package.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006 +++ flexichain/flexichain-package.lisp Fri Jan 25 18:59:21 2008 @@ -25,7 +25,7 @@ #:flexi-error #:flexi-initialization-error #:flexi-position-error #:flexi-incompatible-type-error #:nb-elements #:flexi-empty-p - #:insert* #:insert-vector* #:element* #:delete* + #:insert* #:insert-vector* #:element* #:delete* #:delete-elements* #:push-start #:pop-start #:push-end #:pop-end #:rotate #:cursorchain #:standard-cursorchain #:flexicursor #:standard-flexicursor Index: flexichain/flexichain.asd diff -u flexichain/flexichain.asd:1.4 flexichain/flexichain.asd:1.5 --- flexichain/flexichain.asd:1.4 Tue Jan 30 11:37:42 2007 +++ flexichain/flexichain.asd Fri Jan 25 18:59:21 2008 @@ -23,7 +23,7 @@ ;; for testing. (asdf:defsystem :flexichain :name "flexichain" - :version "1.2" + :version "1.3" :components ((:file "flexichain-package") (:file "utilities" :depends-on ("flexichain-package")) (:file "flexichain" :depends-on ("utilities" "flexichain-package")) Index: flexichain/flexichain.lisp diff -u flexichain/flexichain.lisp:1.3 flexichain/flexichain.lisp:1.4 --- flexichain/flexichain.lisp:1.3 Fri Nov 3 18:24:09 2006 +++ flexichain/flexichain.lisp Fri Jan 25 18:59:21 2008 @@ -111,6 +111,13 @@ to the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled.")) +(defgeneric delete-elements* (chain position n) + (:documentation "Delete N elements at POSITION of the chain. If +POSITION+N is out of range (less than 0 or greater than or equal +to the length of CHAIN, the FLEXI-POSITION-ERROR condition will +be signaled. N can be negative, in which case elements will be +deleted before POSITION.")) + (defgeneric element* (chain position) (:documentation "Returns the element at POSITION of the chain. If POSITION is out of range (less than 0 or greater than or equal @@ -288,6 +295,23 @@ (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor)))) (decrease-buffer-size chain)))) +(defmethod delete-elements* ((chain standard-flexichain) position n) + (unless (zerop n) + (with-slots (buffer expand-factor min-size fill-element gap-end gap-start) chain + (when (minusp n) + (incf position n) + (setf n (* -1 n))) + (assert (<= 0 (+ position n) (nb-elements chain)) () + 'flexi-position-error :chain chain :position position) + (ensure-gap-position chain position) + (fill-gap chain gap-end (+ gap-end n)) + (incf gap-end n) + (when (= gap-end (length buffer)) + (setf gap-end 0)) + (when (and (> (length buffer) (+ min-size 2)) + (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor)))) + (decrease-buffer-size chain))))) + (defmethod element* ((chain standard-flexichain) position) (with-slots (buffer) chain (assert (< -1 position (nb-elements chain)) () Index: flexichain/flexicursor.lisp diff -u flexichain/flexicursor.lisp:1.2 flexichain/flexicursor.lisp:1.3 --- flexichain/flexicursor.lisp:1.2 Tue Oct 17 12:02:02 2006 +++ flexichain/flexicursor.lisp Fri Jan 25 18:59:21 2008 @@ -148,7 +148,7 @@ (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))))) + (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2))))) (defmethod clone-cursor ((cursor standard-flexicursor)) (make-instance (class-of cursor) @@ -161,9 +161,8 @@ (defmethod (setf cursor-pos) (position (cursor left-sticky-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () 'flexi-position-error :chain (chain cursor) :position position) - (with-slots (chain index) cursor - (with-slots (cursors) chain - (setf index (position-index chain (1- position)))))) + (with-slots (chain) cursor + (setf (flexicursor-index cursor) (position-index chain (1- position))))) (defmethod cursor-pos ((cursor right-sticky-flexicursor)) (index-position (chain cursor) (slot-value cursor 'index))) @@ -171,9 +170,8 @@ (defmethod (setf cursor-pos) (position (cursor right-sticky-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () 'flexi-position-error :chain (chain cursor) :position position) - (with-slots (chain index) cursor - (with-slots (cursors) chain - (setf index (position-index chain position))))) + (with-slots (chain) cursor + (setf (flexicursor-index cursor) (position-index chain position)))) (defmethod at-beginning-p ((cursor standard-flexicursor)) (zerop (cursor-pos cursor))) @@ -200,6 +198,24 @@ (right-sticky-flexicursor (incf (cursor-pos cursor))) (left-sticky-flexicursor (decf (cursor-pos cursor)))))))) +(defmethod delete-elements* :before ((chain standard-cursorchain) position n) + (with-slots (cursors) chain + (when (minusp n) + (incf position n) + (setf n (* -1 n))) + (unless (zerop n) + (let* ((start-index (position-index chain position)) + (end-index (position-index chain (+ position n -1)))) + (loop for cursor-wp in cursors + as cursor = (weak-pointer-value cursor-wp) + when (and cursor (<= start-index (flexicursor-index cursor) + end-index)) + do (typecase cursor + (right-sticky-flexicursor (setf (cursor-pos cursor) + (+ position n))) + (left-sticky-flexicursor (setf (cursor-pos cursor) + position)))))))) + (defmethod delete> ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) (position (cursor-pos cursor)))

1 0