/[flexichain]/flexichain/flexicursor.lisp
ViewVC logotype

Diff of /flexichain/flexicursor.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by rkreuter, Thu Feb 9 02:51:06 2006 UTC revision 1.5 by charmon, Sun Jan 27 06:05:37 2008 UTC
# Line 96  sequence was inserted using INSERT.")) Line 96  sequence was inserted using INSERT."))
96  (defgeneric (setf element>) (object cursor)  (defgeneric (setf element>) (object cursor)
97    (:documentation "Replaces the element immediately after the cursor."))    (:documentation "Replaces the element immediately after the cursor."))
98    
99  (defclass standard-cursorchain  (defclass standard-cursorchain (cursorchain standard-flexichain)
     (weak-pointer-container-mixin cursorchain standard-flexichain)  
100    ((cursors :initform '()))    ((cursors :initform '()))
101    (:documentation "The standard instantiable subclass of CURSORCHAIN"))    (:documentation "The standard instantiable subclass of CURSORCHAIN"))
102    
# Line 111  sequence was inserted using INSERT.")) Line 110  sequence was inserted using INSERT."))
110  (defclass right-sticky-flexicursor (standard-flexicursor) ())  (defclass right-sticky-flexicursor (standard-flexicursor) ())
111    
112  (defmethod initialize-instance :after ((cursor left-sticky-flexicursor)  (defmethod initialize-instance :after ((cursor left-sticky-flexicursor)
113                                         &rest initargs &key (position 0))                                         &rest initargs &key (position 0))
114    (declare (ignore initargs))    (declare (ignore initargs))
115    (with-slots (index chain) cursor    (with-slots (index chain) cursor
116       (setf index (position-index chain (1- position)))       (setf index (position-index chain (1- position)))
117       (with-slots (cursors) chain       (with-slots (cursors) chain
118          (push (make-weak-pointer cursor chain) cursors))))          (push (make-weak-pointer cursor) cursors))))
119    
120  (defmethod initialize-instance :after ((cursor right-sticky-flexicursor)  (defmethod initialize-instance :after ((cursor right-sticky-flexicursor)
121                                         &rest initargs &key (position 0))                                         &rest initargs &key (position 0))
122    (declare (ignore initargs))    (declare (ignore initargs))
123    (with-slots (index chain) cursor    (with-slots (index chain) cursor
124       (setf index (position-index chain position))       (setf index (position-index chain position))
125       (with-slots (cursors) chain       (with-slots (cursors) chain
126          (push (make-weak-pointer cursor chain) cursors))))          (push (make-weak-pointer cursor) cursors))))
127    
128  (defun adjust-cursors (chain cursors start end increment)  (defun adjust-cursors (cursors start end increment)
129    (let ((acc '()))    (let ((acc '()))
130      (loop      (loop
131         for cursor = (and cursors (weak-pointer-value (car cursors) chain))         for cursor = (and cursors (weak-pointer-value (car cursors)))
132         while cursors         while cursors
133         do (cond ((null cursor)         do (cond ((null cursor)
134                   (pop cursors))                   (pop cursors))
135                  ((<= start (flexicursor-index cursor) end)                  ((<= start (flexicursor-index cursor) end)
136                      (incf (flexicursor-index cursor) increment)                      (incf (flexicursor-index cursor) increment)
137                      (let ((rest (cdr cursors)))                      (let ((rest (cdr cursors)))
138                        (setf (cdr cursors) acc                        (setf (cdr cursors) acc
139                              acc cursors                              acc cursors
140                              cursors rest)))                              cursors rest)))
141                  (t                  (t
142                   (let ((rest (cdr cursors)))                   (let ((rest (cdr cursors)))
143                     (setf (cdr cursors) acc                     (setf (cdr cursors) acc
144                           acc cursors                           acc cursors
145                           cursors rest)))))                           cursors rest)))))
146      acc))      acc))
147    
148  (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)  (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
149    (declare (ignore to from))    (declare (ignore to from))
150    (with-slots (cursors) cc    (with-slots (cursors) cc
151       (setf cursors (adjust-cursors cc cursors start2 (1- end2) (- start1 start2)))))      (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2)))))
152    
153  (defmethod clone-cursor ((cursor standard-flexicursor))  (defmethod clone-cursor ((cursor standard-flexicursor))
154    (make-instance (class-of cursor)    (make-instance (class-of cursor)
# Line 161  sequence was inserted using INSERT.")) Line 160  sequence was inserted using INSERT."))
160    
161  (defmethod (setf cursor-pos) (position (cursor left-sticky-flexicursor))  (defmethod (setf cursor-pos) (position (cursor left-sticky-flexicursor))
162    (assert (<= 0 position (nb-elements (chain cursor))) ()    (assert (<= 0 position (nb-elements (chain cursor))) ()
163            'flexi-position-error :chain (chain cursor) :position position)            'flexi-position-error :chain (chain cursor) :position position)
164    (with-slots (chain index) cursor    (with-slots (chain) cursor
165       (with-slots (cursors) chain      (setf (flexicursor-index cursor) (position-index chain (1- position)))))
         (setf index (position-index chain (1- position))))))  
166    
167  (defmethod cursor-pos ((cursor right-sticky-flexicursor))  (defmethod cursor-pos ((cursor right-sticky-flexicursor))
168    (index-position (chain cursor) (slot-value cursor 'index)))    (index-position (chain cursor) (slot-value cursor 'index)))
169    
170  (defmethod (setf cursor-pos) (position (cursor right-sticky-flexicursor))  (defmethod (setf cursor-pos) (position (cursor right-sticky-flexicursor))
171    (assert (<= 0 position (nb-elements (chain cursor))) ()    (assert (<= 0 position (nb-elements (chain cursor))) ()
172            'flexi-position-error :chain (chain cursor) :position position)            'flexi-position-error :chain (chain cursor) :position position)
173    (with-slots (chain index) cursor    (with-slots (chain) cursor
174       (with-slots (cursors) chain      (setf (flexicursor-index cursor) (position-index chain position))))
         (setf index (position-index chain position)))))  
175    
176  (defmethod at-beginning-p ((cursor standard-flexicursor))  (defmethod at-beginning-p ((cursor standard-flexicursor))
177    (zerop (cursor-pos cursor)))    (zerop (cursor-pos cursor)))
# Line 188  sequence was inserted using INSERT.")) Line 185  sequence was inserted using INSERT."))
185  (defmethod insert-sequence ((cursor standard-flexicursor) sequence)  (defmethod insert-sequence ((cursor standard-flexicursor) sequence)
186    (map nil    (map nil
187         (lambda (object)         (lambda (object)
188           (insert cursor object))           (insert cursor object))
189         sequence))         sequence))
190    
191  (defmethod delete* :before ((chain standard-cursorchain) position)  (defmethod delete* :before ((chain standard-cursorchain) position)
192    (with-slots (cursors) chain    (with-slots (cursors) chain
193       (let* ((old-index (position-index chain position)))       (let* ((old-index (position-index chain position)))
194         (loop for cursor-wp in cursors         (loop for cursor-wp in cursors
195               as cursor = (weak-pointer-value cursor-wp chain)               as cursor = (weak-pointer-value cursor-wp)
196               when (and cursor (= old-index (flexicursor-index cursor)))               when (and cursor (= old-index (flexicursor-index cursor)))
197                 do (typecase cursor                 do (typecase cursor
198                      (right-sticky-flexicursor (incf (cursor-pos cursor)))                      (right-sticky-flexicursor (incf (cursor-pos cursor)))
199                      (left-sticky-flexicursor (decf (cursor-pos cursor))))))))                      (left-sticky-flexicursor (decf (cursor-pos cursor))))))))
200    
201    (defmethod delete-elements* :before ((chain standard-cursorchain) position n)
202      (with-slots (cursors) chain
203        (when (minusp n)
204          (incf position n)
205          (setf n (* -1 n)))
206        (unless (zerop n)
207          (loop for cursor-wp in cursors
208             as cursor = (weak-pointer-value cursor-wp)
209             when (and cursor (<= position (cursor-pos cursor)
210                                  (+ position n)))
211             do (typecase cursor
212                  (right-sticky-flexicursor (setf (cursor-pos cursor)
213                                                  (+ position n)))
214                  (left-sticky-flexicursor (setf (cursor-pos cursor)
215                                                 position)))))))
216    
217  (defmethod delete> ((cursor standard-flexicursor) &optional (n 1))  (defmethod delete> ((cursor standard-flexicursor) &optional (n 1))
218    (let ((chain (chain cursor))    (let ((chain (chain cursor))
219          (position (cursor-pos cursor)))          (position (cursor-pos cursor)))
220      (assert (plusp n) ()      (assert (plusp n) ()
221              'flexi-position-error :chain chain :position n)              'flexi-position-error :chain chain :position n)
222      (loop repeat n      (loop repeat n
223            do (delete* chain position))))            do (delete* chain position))))
224    
225  (defmethod delete< ((cursor standard-flexicursor) &optional (n 1))  (defmethod delete< ((cursor standard-flexicursor) &optional (n 1))
226    (let ((chain (chain cursor))    (let ((chain (chain cursor))
227          (position (cursor-pos cursor)))          (position (cursor-pos cursor)))
228      (assert (plusp n) ()      (assert (plusp n) ()
229              'flexi-position-error :chain chain :position n)              'flexi-position-error :chain chain :position n)
230      (loop repeat n      (loop repeat n
231            do (delete* chain (- position n)))))            do (delete* chain (- position n)))))
232    
233  (defmethod element> ((cursor standard-flexicursor))  (defmethod element> ((cursor standard-flexicursor))
234    (assert (not (at-end-p cursor)) ()    (assert (not (at-end-p cursor)) ()

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5