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

Diff of /flexichain/flexichain.lisp

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

revision 1.5 by rstrandh, Sat Jan 26 11:23:09 2008 UTC revision 1.6 by charmon, Sun Jan 27 06:05:37 2008 UTC
# Line 157  at position 0 is now at position N.")) Line 157  at position 0 is now at position N."))
157  (defun required-space (chain nb-elements)  (defun required-space (chain nb-elements)
158    (with-slots (min-size expand-factor) chain    (with-slots (min-size expand-factor) chain
159       (+ 2 (max (ceiling (* nb-elements expand-factor))       (+ 2 (max (ceiling (* nb-elements expand-factor))
160                 min-size))))                 min-size))))
161    
162  (defmethod initialize-instance :after ((chain standard-flexichain)  (defmethod initialize-instance :after ((chain standard-flexichain)
163                                         &rest initargs                                         &rest initargs
# Line 182  at position 0 is now at position N.")) Line 182  at position 0 is now at position N."))
182       (let* ((data-length (if (> (length initial-contents) initial-nb-elements)       (let* ((data-length (if (> (length initial-contents) initial-nb-elements)
183                               (length initial-contents)                               (length initial-contents)
184                               initial-nb-elements))                               initial-nb-elements))
185              (size (required-space chain data-length))              (size (required-space chain data-length))
186              (fill-size (- size data-length 2))              (fill-size (- size data-length 2))
187              (sentinel-list (make-list 2 :initial-element fill-element))              (sentinel-list (make-list 2 :initial-element fill-element))
188              (fill-list (make-list fill-size :initial-element fill-element)))              (fill-list (make-list fill-size :initial-element fill-element)))
189         (setf buffer         (setf buffer
190               (if initial-contents               (if initial-contents
191                   (make-array size                   (make-array size
# Line 209  at position 0 is now at position N.")) Line 209  at position 0 is now at position N."))
209  (defmacro with-virtual-gap ((bl ds gs ge) chain &body body)  (defmacro with-virtual-gap ((bl ds gs ge) chain &body body)
210    (let ((c (gensym)))    (let ((c (gensym)))
211      `(let* ((,c ,chain)      `(let* ((,c ,chain)
212              (,bl (length (slot-value ,c 'buffer)))              (,bl (length (slot-value ,c 'buffer)))
213              (,ds (slot-value ,c 'data-start))              (,ds (slot-value ,c 'data-start))
214              (,gs (slot-value ,c 'gap-start))              (,gs (slot-value ,c 'gap-start))
215              (,ge (slot-value ,c 'gap-end)))              (,ge (slot-value ,c 'gap-end)))
216         (declare (ignorable ,bl ,ds ,gs ,ge))         (declare (ignorable ,bl ,ds ,gs ,ge))
217         (when (< ,gs ,ds) (incf ,gs ,bl))         (when (< ,gs ,ds) (incf ,gs ,bl))
218         (when (< ,ge ,ds) (incf ,ge ,bl))         (when (< ,ge ,ds) (incf ,ge ,bl))
# Line 231  of the CHAIN in the buffer." Line 231  of the CHAIN in the buffer."
231    (with-virtual-gap (bl ds gs ge) chain    (with-virtual-gap (bl ds gs ge) chain
232      (let ((index (+ ds position 1)))      (let ((index (+ ds position 1)))
233        (when (>= index gs)        (when (>= index gs)
234          (incf index (- ge gs)))          (incf index (- ge gs)))
235        (when (>= index bl)        (when (>= index bl)
236          (decf index bl))          (decf index bl))
237        index)))        index)))
238    
239  (defun index-position (chain index)  (defun index-position (chain index)
# Line 258  element of the CHAIN." Line 258  element of the CHAIN."
258  (defmethod insert* ((chain standard-flexichain) position object)  (defmethod insert* ((chain standard-flexichain) position object)
259    (with-slots (element-type buffer gap-start) chain    (with-slots (element-type buffer gap-start) chain
260       (assert (<= 0 position (nb-elements chain)) ()       (assert (<= 0 position (nb-elements chain)) ()
261               'flexi-position-error :chain chain :position position)               'flexi-position-error :chain chain :position position)
262       (assert (typep object element-type) ()       (assert (typep object element-type) ()
263               'flexi-incompatible-type-error :element object :chain chain)               'flexi-incompatible-type-error :element object :chain chain)
264       (ensure-gap-position chain position)       (ensure-gap-position chain position)
265       (ensure-room chain (1+ (nb-elements chain)))       (ensure-room chain (1+ (nb-elements chain)))
266       (setf (aref buffer gap-start) object)       (setf (aref buffer gap-start) object)
# Line 271  element of the CHAIN." Line 271  element of the CHAIN."
271  (defmethod insert-vector* ((chain standard-flexichain) position vector)  (defmethod insert-vector* ((chain standard-flexichain) position vector)
272    (with-slots (element-type buffer gap-start) chain    (with-slots (element-type buffer gap-start) chain
273       (assert (<= 0 position (nb-elements chain)) ()       (assert (<= 0 position (nb-elements chain)) ()
274               'flexi-position-error :chain chain :position position)               'flexi-position-error :chain chain :position position)
275       (assert (subtypep (array-element-type  vector) element-type) ()       (assert (subtypep (array-element-type vector) element-type) ()
276               'flexi-incompatible-type-error :element vector :chain chain)               'flexi-incompatible-type-error :element vector :chain chain)
277       (ensure-gap-position chain position)       (ensure-gap-position chain position)
278       (ensure-room chain (+ (nb-elements chain) (length vector)))       (ensure-room chain (+ (nb-elements chain) (length vector)))
279       (loop for elem across vector       (loop for elem across vector
280             do (setf (aref buffer gap-start) elem)          do (setf (aref buffer gap-start) elem)
281                (incf gap-start)            (incf gap-start)
282                (when (= gap-start (length buffer))            (when (= gap-start (length buffer))
283                  (setf gap-start 0)))))              (setf gap-start 0)))))
284    
285  (defmethod delete* ((chain standard-flexichain) position)  (defmethod delete* ((chain standard-flexichain) position)
286    (with-slots (buffer expand-factor min-size fill-element gap-end) chain    (with-slots (buffer expand-factor min-size fill-element gap-end) chain
# Line 292  element of the CHAIN." Line 292  element of the CHAIN."
292      (when (= gap-end (length buffer))      (when (= gap-end (length buffer))
293        (setf gap-end 0))        (setf gap-end 0))
294      (when (and (> (length buffer) (+ min-size 2))      (when (and (> (length buffer) (+ min-size 2))
295                 (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor))))                 (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor))))
296        (decrease-buffer-size chain))))        (decrease-buffer-size chain))))
297    
298  (defmethod delete-elements* ((chain standard-flexichain) position n)  (defmethod delete-elements* ((chain standard-flexichain) position n)
# Line 324  element of the CHAIN." Line 324  element of the CHAIN."
324  (defmethod element* ((chain standard-flexichain) position)  (defmethod element* ((chain standard-flexichain) position)
325    (with-slots (buffer) chain    (with-slots (buffer) chain
326       (assert (< -1 position (nb-elements chain)) ()       (assert (< -1 position (nb-elements chain)) ()
327               'flexi-position-error :chain chain :position position)               'flexi-position-error :chain chain :position position)
328       (aref buffer (position-index chain position))))       (aref buffer (position-index chain position))))
329    
330  (defmethod (setf element*) (object (chain standard-flexichain) position)  (defmethod (setf element*) (object (chain standard-flexichain) position)
331    (with-slots (buffer element-type) chain    (with-slots (buffer element-type) chain
332       (assert (< -1 position (nb-elements chain)) ()       (assert (< -1 position (nb-elements chain)) ()
333               'flexi-position-error :chain chain :position position)               'flexi-position-error :chain chain :position position)
334       (assert (typep object element-type) ()       (assert (typep object element-type) ()
335               'flexi-incompatible-type-error :chain chain :element object)               'flexi-incompatible-type-error :chain chain :element object)
336       (setf (aref buffer (position-index chain position)) object)))       (setf (aref buffer (position-index chain position)) object)))
337    
338  (defmethod push-start ((chain standard-flexichain) object)  (defmethod push-start ((chain standard-flexichain) object)
# Line 342  element of the CHAIN." Line 342  element of the CHAIN."
342    (insert* chain (nb-elements chain) object))    (insert* chain (nb-elements chain) object))
343    
344  (defmethod pop-start ((chain standard-flexichain))  (defmethod pop-start ((chain standard-flexichain))
345    (prog1 (element* chain 0)    (prog1
346           (delete* chain 0)))        (element* chain 0)
347        (delete* chain 0)))
348    
349  (defmethod pop-end ((chain standard-flexichain))  (defmethod pop-end ((chain standard-flexichain))
350    (let ((position (1- (nb-elements chain))))    (let ((position (1- (nb-elements chain))))
351      (prog1 (element* chain position)      (prog1
352             (delete* chain position))))          (element* chain position)
353          (delete* chain position))))
354    
355  (defmethod rotate ((chain standard-flexichain) &optional (n 1))  (defmethod rotate ((chain standard-flexichain) &optional (n 1))
356    (when (> (nb-elements chain) 1)    (when (> (nb-elements chain) 1)
357      (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain))))      (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain))))
358            ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain))))            ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain))))
359            (t nil))))            (t nil))))
360    
361  (defun move-gap (chain hot-spot)  (defun move-gap (chain hot-spot)
362    "Moves the elements and gap inside the buffer so that    "Moves the elements and gap inside the buffer so that
# Line 474  PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2 Line 476  PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2
476      (let* ((buffer-size (length buffer))      (let* ((buffer-size (length buffer))
477             (rotated-gap-end (if (zerop gap-end) buffer-size gap-end)))             (rotated-gap-end (if (zerop gap-end) buffer-size gap-end)))
478        (move-elements chain buffer buffer        (move-elements chain buffer buffer
479                       (- rotated-gap-end count) (- gap-start count) gap-start)                       (- rotated-gap-end count) (- gap-start count) gap-start)
480        (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count)))        (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count)))
481        (decf gap-start count)        (decf gap-start count)
482        (setf gap-end (- rotated-gap-end count))        (setf gap-end (- rotated-gap-end count))
# Line 488  HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2 Line 490  HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2
490      (let* ((buffer-size (length buffer))      (let* ((buffer-size (length buffer))
491             (rotated-gap-start (if (zerop gap-start) buffer-size gap-start)))             (rotated-gap-start (if (zerop gap-start) buffer-size gap-start)))
492        (move-elements chain buffer buffer        (move-elements chain buffer buffer
493                       (- gap-end count) (- rotated-gap-start count) rotated-gap-start)                       (- gap-end count) (- rotated-gap-start count) rotated-gap-start)
494        (fill-gap chain (- rotated-gap-start count) rotated-gap-start)        (fill-gap chain (- rotated-gap-start count) rotated-gap-start)
495        (setf gap-start (- rotated-gap-start count))        (setf gap-start (- rotated-gap-start count))
496        (decf gap-end count)        (decf gap-end count)

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

  ViewVC Help
Powered by ViewVC 1.1.5