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

Contents of /flexichain/flexichain.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Sun Oct 3 08:25:28 2010 UTC (3 years, 6 months ago) by rstrandh
Branch: MAIN
Changes since 1.7: +11 -28 lines
Removed slot indicating the element type that was asked for, because
the method used for cheching this against elements to insert is not
working in most cases because of array upgrading.
1 rkreuter 1.1 ;;; Flexichain
2     ;;; Flexichain data structure definition
3     ;;;
4     ;;; Copyright (C) 2003-2004 Robert Strandh (strandh@labri.fr)
5     ;;; Copyright (C) 2003-2004 Matthieu Villeneuve (matthieu.villeneuve@free.fr)
6     ;;;
7     ;;; This library is free software; you can redistribute it and/or
8     ;;; modify it under the terms of the GNU Lesser General Public
9     ;;; License as published by the Free Software Foundation; either
10     ;;; version 2.1 of the License, or (at your option) any later version.
11     ;;;
12     ;;; This library is distributed in the hope that it will be useful,
13     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15     ;;; Lesser General Public License for more details.
16     ;;;
17     ;;; You should have received a copy of the GNU Lesser General Public
18     ;;; License along with this library; if not, write to the Free Software
19     ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20    
21    
22     (in-package :flexichain)
23    
24     (defclass flexichain ()
25 rstrandh 1.8 ((fill-element :initarg :fill-element)
26 rkreuter 1.1 (expand-factor :initarg :expand-factor :initform 1.5)
27     (min-size :initarg :min-size :initform 5))
28     (:documentation "The protocol class for flexichains."))
29    
30     (defmethod initialize-instance :after ((chain flexichain) &rest initargs
31 rstrandh 1.8 &key initial-contents (element-type t))
32 rkreuter 1.1 (declare (ignore initargs initial-contents))
33     (with-slots (expand-factor min-size) chain
34     (assert (> expand-factor 1) ()
35     'flexichain-initialization-error
36     :cause "EXPAND-FACTOR should be greater than 1.")
37     (assert (> min-size 0) ()
38     'flexichain-initialization-error
39     :cause "MIN-SIZE should be greater than 0."))
40     (if (slot-boundp chain 'fill-element)
41 rstrandh 1.8 (with-slots (fill-element) chain
42 rkreuter 1.1 (assert (typep fill-element element-type) ()
43     'flexichain-initialization-error
44     :cause (format nil "FILL-ELEMENT ~A not of type ~S."
45     fill-element element-type)))
46     (multiple-value-bind (element foundp)
47     (find-if-2 (lambda (x)
48 rstrandh 1.8 (typep x element-type))
49 rkreuter 1.1 '(nil 0 #\a))
50     (if foundp
51     (setf (slot-value chain 'fill-element) element)
52     (error 'flexichain-initialization-error
53     :cause
54     "FILL-ELEMENT not provided, no default applicable.")))))
55    
56     (define-condition flexi-error (simple-error)
57     ())
58    
59     (define-condition flexi-initialization-error (flexi-error)
60     ((cause :reader flexi-initialization-error-cause
61     :initarg :cause :initform ""))
62     (:report (lambda (condition stream)
63     (format stream "Error initializing FLEXICHAIN (~S)"
64     (flexi-initialization-error-cause condition)))))
65    
66     (define-condition flexi-position-error (flexi-error)
67     ((chain :reader flexi-position-error-chain
68     :initarg :chain :initform nil)
69     (position :reader flexi-position-error-position
70     :initarg :position :initform nil))
71     (:report (lambda (condition stream)
72     (format stream "Position ~D out of bounds in ~A"
73     (flexi-position-error-position condition)
74     (flexi-position-error-chain condition)))))
75    
76     (define-condition flexi-incompatible-type-error (flexi-error)
77     ((chain :reader flexi-incompatible-type-error-chain
78     :initarg :chain :initform nil)
79     (element :reader flexi-incompatible-type-error-element
80     :initarg :element :initform nil))
81     (:report (lambda (condition stream)
82     (let ((element (flexi-incompatible-type-error-element
83     condition)))
84     (format stream "Element ~A of type ~A cannot be inserted in ~A"
85     element
86     (type-of element)
87     (flexi-incompatible-type-error-chain condition))))))
88    
89     (defgeneric nb-elements (chain)
90     (:documentation "Returns the number of elements in the flexichain."))
91    
92     (defgeneric flexi-empty-p (chain)
93     (:documentation "Checks whether CHAIN is empty or not."))
94    
95     (defgeneric insert* (chain position object)
96     (:documentation "Inserts an object before the element at POSITION
97     in the chain. If POSITION is out of range (less than 0 or greater
98     than the length of CHAIN, the FLEXI-POSITION-ERROR condition will be
99     signaled."))
100    
101 rstrandh 1.2 (defgeneric insert-vector* (chain position vector)
102     (:documentation "Inserts the elements of VECTOR before the
103     element at POSITION in the chain. If POSITION is out of
104     range (less than 0 or greater than the length of CHAIN, the
105     FLEXI-POSITION-ERROR condition will be signaled."))
106    
107 rkreuter 1.1 (defgeneric delete* (chain position)
108     (:documentation "Deletes an element at POSITION of the chain.
109     If POSITION is out of range (less than 0 or greater than or equal
110     to the length of CHAIN, the FLEXI-POSITION-ERROR condition
111     will be signaled."))
112    
113 charmon 1.4 (defgeneric delete-elements* (chain position n)
114     (:documentation "Delete N elements at POSITION of the chain. If
115     POSITION+N is out of range (less than 0 or greater than or equal
116     to the length of CHAIN, the FLEXI-POSITION-ERROR condition will
117     be signaled. N can be negative, in which case elements will be
118     deleted before POSITION."))
119    
120 rkreuter 1.1 (defgeneric element* (chain position)
121     (:documentation "Returns the element at POSITION of the chain.
122     If POSITION is out of range (less than 0 or greater than or equal
123     to the length of CHAIN, the FLEXI-POSITION-ERROR condition
124     will be signaled."))
125    
126     (defgeneric (setf element*) (object chain position)
127     (:documentation "Replaces the element at POSITION of CHAIN by OBJECT.
128     If POSITION if out of range (less than 0 or greater than or equal to
129     the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled."))
130    
131     (defgeneric push-start (chain object)
132     (:documentation "Inserts an object at the beginning of CHAIN."))
133    
134     (defgeneric push-end (chain object)
135     (:documentation "Inserts an object at the end of CHAIN."))
136    
137     (defgeneric pop-start (chain)
138     (:documentation "Pops and returns the element at the beginning of CHAIN."))
139    
140     (defgeneric pop-end (chain)
141     (:documentation "Pops and returns the element at the end of CHAIN."))
142    
143     (defgeneric rotate (chain &optional n)
144     (:documentation "Rotates the elements of CHAIN so that the element
145     that used to be at position N is now at position 0. With a negative
146     value of N, rotates the elements so that the element that used to be
147     at position 0 is now at position N."))
148    
149     (defclass standard-flexichain (flexichain)
150     ((buffer)
151     (gap-start)
152     (gap-end)
153     (data-start))
154     (:documentation "The standard instantiable subclass of FLEXICHAIN."))
155    
156     (defun required-space (chain nb-elements)
157     (with-slots (min-size expand-factor) chain
158     (+ 2 (max (ceiling (* nb-elements expand-factor))
159 charmon 1.6 min-size))))
160 rkreuter 1.1
161     (defmethod initialize-instance :after ((chain standard-flexichain)
162     &rest initargs
163 charmon 1.3 &key
164     initial-contents
165 rstrandh 1.8 (element-type t)
166 charmon 1.3 (initial-nb-elements 0)
167     (initial-element nil))
168 rkreuter 1.1 (declare (ignore initargs))
169     ;; Initialize slots
170 rstrandh 1.8 (with-slots (fill-element buffer) chain
171 charmon 1.3 (let* ((data-length (if (> (length initial-contents) initial-nb-elements)
172     (length initial-contents)
173     initial-nb-elements))
174 charmon 1.6 (size (required-space chain data-length))
175     (fill-size (- size data-length 2))
176     (sentinel-list (make-list 2 :initial-element fill-element))
177     (fill-list (make-list fill-size :initial-element fill-element)))
178 rkreuter 1.1 (setf buffer
179 charmon 1.3 (if initial-contents
180     (make-array size
181     :element-type element-type
182     :initial-contents (concatenate 'list
183     sentinel-list
184     initial-contents
185     fill-list))
186     (let ((arr (make-array size
187     :element-type element-type
188     :initial-element initial-element)))
189     (fill arr fill-element :end (length sentinel-list))
190     (fill arr fill-element
191     :start (+ (length sentinel-list) initial-nb-elements)
192     :end size))))
193     (with-slots (gap-start gap-end data-start) chain
194     (setf gap-start (+ 2 data-length)
195     gap-end 0
196     data-start 1)))))
197 rkreuter 1.1
198     (defmacro with-virtual-gap ((bl ds gs ge) chain &body body)
199     (let ((c (gensym)))
200     `(let* ((,c ,chain)
201 charmon 1.6 (,bl (length (slot-value ,c 'buffer)))
202     (,ds (slot-value ,c 'data-start))
203     (,gs (slot-value ,c 'gap-start))
204     (,ge (slot-value ,c 'gap-end)))
205 rkreuter 1.1 (declare (ignorable ,bl ,ds ,gs ,ge))
206     (when (< ,gs ,ds) (incf ,gs ,bl))
207     (when (< ,ge ,ds) (incf ,ge ,bl))
208     ,@body)))
209    
210     (defmethod nb-elements ((chain standard-flexichain))
211     (with-virtual-gap (bl ds gs ge) chain
212     (- bl (- ge gs) 2)))
213    
214     (defmethod flexi-empty-p ((chain standard-flexichain))
215     (zerop (nb-elements chain)))
216    
217     (defun position-index (chain position)
218     "Returns the (0 indexed) index of the POSITION-th element
219     of the CHAIN in the buffer."
220     (with-virtual-gap (bl ds gs ge) chain
221     (let ((index (+ ds position 1)))
222     (when (>= index gs)
223 charmon 1.6 (incf index (- ge gs)))
224 rkreuter 1.1 (when (>= index bl)
225 charmon 1.6 (decf index bl))
226 rkreuter 1.1 index)))
227    
228     (defun index-position (chain index)
229     "Returns the position corresponding to the INDEX in the CHAIN.
230     Note: the result is undefined if INDEX is not the index of a valid
231     element of the CHAIN."
232     (with-virtual-gap (bl ds gs ge) chain
233     (when (< index ds)
234     (incf index bl))
235     (when (>= index ge)
236     (decf index (- ge gs)))
237     (- index ds 1)))
238    
239     (defun ensure-gap-position (chain position)
240     (move-gap chain (position-index chain position)))
241    
242     (defun ensure-room (chain nb-elements)
243     (with-slots (buffer) chain
244     (when (> nb-elements (- (length buffer) 2))
245     (increase-buffer-size chain nb-elements))))
246    
247     (defmethod insert* ((chain standard-flexichain) position object)
248 rstrandh 1.8 (with-slots (buffer gap-start) chain
249 rkreuter 1.1 (assert (<= 0 position (nb-elements chain)) ()
250 charmon 1.6 'flexi-position-error :chain chain :position position)
251 rkreuter 1.1 (ensure-gap-position chain position)
252     (ensure-room chain (1+ (nb-elements chain)))
253     (setf (aref buffer gap-start) object)
254     (incf gap-start)
255     (when (= gap-start (length buffer))
256     (setf gap-start 0))))
257    
258     (defmethod insert-vector* ((chain standard-flexichain) position vector)
259 rstrandh 1.8 (with-slots (buffer gap-start) chain
260 rkreuter 1.1 (assert (<= 0 position (nb-elements chain)) ()
261 charmon 1.6 'flexi-position-error :chain chain :position position)
262 rkreuter 1.1 (ensure-gap-position chain position)
263     (ensure-room chain (+ (nb-elements chain) (length vector)))
264     (loop for elem across vector
265 charmon 1.6 do (setf (aref buffer gap-start) elem)
266     (incf gap-start)
267     (when (= gap-start (length buffer))
268     (setf gap-start 0)))))
269 rkreuter 1.1
270     (defmethod delete* ((chain standard-flexichain) position)
271     (with-slots (buffer expand-factor min-size fill-element gap-end) chain
272     (assert (< -1 position (nb-elements chain)) ()
273     'flexi-position-error :chain chain :position position)
274     (ensure-gap-position chain position)
275     (setf (aref buffer gap-end) fill-element)
276     (incf gap-end)
277     (when (= gap-end (length buffer))
278     (setf gap-end 0))
279     (when (and (> (length buffer) (+ min-size 2))
280 charmon 1.6 (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor))))
281 rkreuter 1.1 (decrease-buffer-size chain))))
282    
283 charmon 1.4 (defmethod delete-elements* ((chain standard-flexichain) position n)
284     (unless (zerop n)
285 rstrandh 1.5 (with-slots (buffer expand-factor min-size gap-end data-start) chain
286 charmon 1.4 (when (minusp n)
287     (incf position n)
288     (setf n (* -1 n)))
289     (assert (<= 0 (+ position n) (nb-elements chain)) ()
290     'flexi-position-error :chain chain :position position)
291     (ensure-gap-position chain position)
292 rstrandh 1.5 ;; Two cases to consider - one where position+n is wholly on
293     ;; this side of the gap in buffer, and one where part of it is
294     ;; "wrapped around" to the beginning of buffer.
295     (cond ((>= (length buffer) (+ gap-end n))
296     (fill-gap chain gap-end (+ gap-end n))
297     (incf gap-end n))
298     (t (let ((surplus-elements (- n (- (length buffer) gap-end))))
299     (fill-gap chain gap-end (length buffer))
300     (fill-gap chain 0 surplus-elements)
301 charmon 1.7 (setf gap-end surplus-elements))))
302 charmon 1.4 (when (= gap-end (length buffer))
303     (setf gap-end 0))
304     (when (and (> (length buffer) (+ min-size 2))
305     (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor))))
306     (decrease-buffer-size chain)))))
307    
308 rkreuter 1.1 (defmethod element* ((chain standard-flexichain) position)
309     (with-slots (buffer) chain
310     (assert (< -1 position (nb-elements chain)) ()
311 charmon 1.6 'flexi-position-error :chain chain :position position)
312 rkreuter 1.1 (aref buffer (position-index chain position))))
313    
314     (defmethod (setf element*) (object (chain standard-flexichain) position)
315 rstrandh 1.8 (with-slots (buffer) chain
316 rkreuter 1.1 (assert (< -1 position (nb-elements chain)) ()
317 charmon 1.6 'flexi-position-error :chain chain :position position)
318 rkreuter 1.1 (setf (aref buffer (position-index chain position)) object)))
319    
320     (defmethod push-start ((chain standard-flexichain) object)
321     (insert* chain 0 object))
322    
323     (defmethod push-end ((chain standard-flexichain) object)
324     (insert* chain (nb-elements chain) object))
325    
326     (defmethod pop-start ((chain standard-flexichain))
327 charmon 1.6 (prog1
328     (element* chain 0)
329     (delete* chain 0)))
330 rkreuter 1.1
331     (defmethod pop-end ((chain standard-flexichain))
332     (let ((position (1- (nb-elements chain))))
333 charmon 1.6 (prog1
334     (element* chain position)
335     (delete* chain position))))
336 rkreuter 1.1
337     (defmethod rotate ((chain standard-flexichain) &optional (n 1))
338     (when (> (nb-elements chain) 1)
339     (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain))))
340 charmon 1.6 ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain))))
341     (t nil))))
342 rkreuter 1.1
343     (defun move-gap (chain hot-spot)
344     "Moves the elements and gap inside the buffer so that
345     the element currently at HOT-SPOT becomes the first element following
346     the gap, or does nothing if there are no elements."
347     (with-slots (gap-start gap-end) chain
348     (unless (= hot-spot gap-end)
349     (case (gap-location chain)
350     (:gap-empty (move-empty-gap chain hot-spot))
351     (:gap-left (move-left-gap chain hot-spot))
352     (:gap-right (move-right-gap chain hot-spot))
353     (:gap-middle (move-middle-gap chain hot-spot))
354     (:gap-non-contiguous (move-non-contiguous-gap chain hot-spot))))
355     (values gap-start gap-end)))
356    
357     (defun move-empty-gap (chain hot-spot)
358     "Moves the gap. Handles the case where the gap is empty."
359     (with-slots (gap-start gap-end) chain
360     (setf gap-start hot-spot
361     gap-end hot-spot)))
362    
363     (defun move-left-gap (chain hot-spot)
364     "Moves the gap. Handles the case where the gap is
365     on the left of the buffer."
366     (with-slots (buffer gap-start gap-end data-start) chain
367     (let ((buffer-size (length buffer)))
368     (cond ((< (- hot-spot gap-end) (- buffer-size hot-spot))
369     (push-elements-left chain (- hot-spot gap-end)))
370     ((<= (- buffer-size hot-spot) gap-end)
371     (hop-elements-left chain (- buffer-size hot-spot)))
372     (t
373     (hop-elements-left chain (- gap-end gap-start))
374     (push-elements-right chain (- gap-start hot-spot)))))))
375    
376     (defun move-right-gap (chain hot-spot)
377     "Moves the gap. Handles the case where the gap is
378     on the right of the buffer."
379     (with-slots (buffer gap-start gap-end) chain
380     (let ((buffer-size (length buffer)))
381     (cond ((< (- gap-start hot-spot) hot-spot)
382     (push-elements-right chain (- gap-start hot-spot)))
383     ((<= hot-spot (- buffer-size gap-start))
384     (hop-elements-right chain hot-spot))
385     (t
386     (hop-elements-right chain (- buffer-size gap-start))
387     (push-elements-left chain (- hot-spot gap-end)))))))
388    
389     (defun move-middle-gap (chain hot-spot)
390     "Moves the gap. Handles the case where the gap is
391     in the middle of the buffer."
392     (with-slots (buffer gap-start gap-end) chain
393     (let ((buffer-size (length buffer)))
394     (cond ((< hot-spot gap-start)
395     (cond ((<= (- gap-start hot-spot)
396     (+ (- buffer-size gap-end) hot-spot))
397     (push-elements-right chain (- gap-start hot-spot)))
398     (t
399     (push-elements-left chain (- buffer-size gap-end))
400     (move-right-gap chain hot-spot))))
401     (t
402     (cond ((< (- hot-spot gap-end)
403     (+ (- buffer-size hot-spot) gap-start))
404     (push-elements-left chain (- hot-spot gap-end)))
405     (t
406     (push-elements-right chain gap-start)
407     (move-left-gap chain hot-spot))))))))
408    
409     (defun move-non-contiguous-gap (chain hot-spot)
410     "Moves the gap. Handles the case where the gap is in 2 parts,
411     on both ends of the buffer."
412     (with-slots (buffer gap-start gap-end) chain
413     (let ((buffer-size (length buffer)))
414     (cond ((< (- hot-spot gap-end) (- gap-start hot-spot))
415     (hop-elements-right chain (min (- buffer-size gap-start)
416     (- hot-spot gap-end)))
417     (let ((nb-left (- hot-spot gap-end)))
418     (unless (zerop nb-left)
419     (push-elements-left chain nb-left))))
420     (t
421     (hop-elements-left chain (min gap-end (- gap-start hot-spot)))
422     (let ((nb-right (- gap-start hot-spot)))
423     (unless (zerop nb-right)
424     (push-elements-right chain nb-right))))))))
425    
426     (defgeneric move-elements (standard-flexichain to from start1 start2 end2)
427     (:documentation "move elements of a flexichain and adjust data-start"))
428    
429     (defmethod move-elements ((fc standard-flexichain) to from start1 start2 end2)
430     (replace to from :start1 start1 :start2 start2 :end2 end2)
431     (with-slots (data-start) fc
432     (when (and (<= start2 data-start) (< data-start end2))
433     (incf data-start (- start1 start2)))))
434    
435     (defgeneric fill-gap (standard-flexichain start end)
436     (:documentation "fill part of gap with the fill element"))
437    
438     (defmethod fill-gap ((fc standard-flexichain) start end)
439     (with-slots (buffer fill-element) fc
440     (fill buffer fill-element :start start :end end)))
441    
442     (defun push-elements-left (chain count)
443     "Pushes the COUNT elements of CHAIN at the right of the gap,
444     to the beginning of the gap. The gap must be continuous. Example:
445     PUSH-ELEMENTS-LEFT abcd-----efghijklm 2 => abcdef-----ghijklm"
446     (with-slots (buffer gap-start gap-end) chain
447     (move-elements chain buffer buffer gap-start gap-end (+ gap-end count))
448     (fill-gap chain (max gap-end (+ gap-start count)) (+ gap-end count))
449     (incf gap-start count)
450     (incf gap-end count)
451     (normalize-indices chain)))
452    
453     (defun push-elements-right (chain count)
454     "Pushes the COUNT elements of CHAIN at the left of the gap,
455     to the end of the gap. The gap must be continuous. Example:
456     PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2 => ab-----cdefghijklm"
457     (with-slots (buffer gap-start gap-end) chain
458     (let* ((buffer-size (length buffer))
459     (rotated-gap-end (if (zerop gap-end) buffer-size gap-end)))
460     (move-elements chain buffer buffer
461 charmon 1.6 (- rotated-gap-end count) (- gap-start count) gap-start)
462 rkreuter 1.1 (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count)))
463     (decf gap-start count)
464     (setf gap-end (- rotated-gap-end count))
465     (normalize-indices chain))))
466    
467     (defun hop-elements-left (chain count)
468     "Moves the COUNT rightmost elements to the end of the gap,
469     on the left of the data. Example:
470     HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2 => -lmabcdefghijk-----"
471     (with-slots (buffer gap-start gap-end) chain
472     (let* ((buffer-size (length buffer))
473     (rotated-gap-start (if (zerop gap-start) buffer-size gap-start)))
474     (move-elements chain buffer buffer
475 charmon 1.6 (- gap-end count) (- rotated-gap-start count) rotated-gap-start)
476 rkreuter 1.1 (fill-gap chain (- rotated-gap-start count) rotated-gap-start)
477     (setf gap-start (- rotated-gap-start count))
478     (decf gap-end count)
479     (normalize-indices chain))))
480    
481     (defun hop-elements-right (chain count)
482     "Moves the COUNT leftmost elements to the beginning of the gap,
483     on the right of the data. Example:
484     HOP-ELEMENTS-RIGHT ---abcdefghijklm--- 2 => -----cdefghijklmab-"
485     (with-slots (buffer gap-start gap-end) chain
486     (move-elements chain buffer buffer gap-start gap-end (+ gap-end count))
487     (fill-gap chain gap-end (+ gap-end count))
488     (incf gap-start count)
489     (incf gap-end count)
490     (normalize-indices chain)))
491    
492     (defun increase-buffer-size (chain nb-elements)
493     (resize-buffer chain (required-space chain nb-elements)))
494    
495     (defun decrease-buffer-size (chain)
496     (resize-buffer chain (required-space chain (nb-elements chain))))
497    
498     (defgeneric resize-buffer (standard-flexichain new-buffer-size)
499     (:documentation "allocate a new buffer with the size indicated"))
500    
501     (defmethod resize-buffer ((fc standard-flexichain) new-buffer-size)
502     (with-slots (buffer gap-start gap-end
503 rstrandh 1.8 fill-element expand-factor) fc
504 rkreuter 1.1 (let ((buffer-size (length buffer))
505     (buffer-after (make-array new-buffer-size
506 rstrandh 1.8 :element-type (array-element-type buffer)
507 rkreuter 1.1 :initial-element fill-element)))
508     (case (gap-location fc)
509     ((:gap-empty :gap-middle)
510     (move-elements fc buffer-after buffer 0 0 gap-start)
511     (let ((gap-end-after (- new-buffer-size (- buffer-size gap-end))))
512     (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size)
513     (setf gap-end gap-end-after)))
514     (:gap-right
515     (move-elements fc buffer-after buffer 0 0 gap-start))
516     (:gap-left
517     (let ((gap-end-after (- new-buffer-size (+ 2 (nb-elements fc)))))
518     (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size)
519     (setf gap-end gap-end-after)))
520     (:gap-non-contiguous
521     (move-elements fc buffer-after buffer 0 gap-end gap-start)
522     (decf gap-start gap-end)
523     (setf gap-end 0)))
524     (setf buffer buffer-after)))
525     (normalize-indices fc))
526    
527     (defun normalize-indices (chain)
528     "Sets gap limits to 0 if they are at the end of the buffer."
529     (with-slots (buffer gap-start gap-end data-start) chain
530     (let ((buffer-size (length buffer)))
531     (when (>= data-start buffer-size)
532     (setf data-start 0))
533     (when (>= gap-start buffer-size)
534     (setf gap-start 0))
535     (when (>= gap-end buffer-size)
536     (setf gap-end 0)))))
537    
538     (defun gap-location (chain)
539     "Returns a keyword indicating the general location of the gap."
540     (with-slots (buffer gap-start gap-end) chain
541     (cond ((= gap-start gap-end) :gap-empty)
542     ((and (zerop gap-start) (>= gap-end 0)) :gap-left)
543     ((and (zerop gap-end) (> gap-start 0)) :gap-right)
544     ((> gap-end gap-start) :gap-middle)
545     (t :gap-non-contiguous))))
546    

  ViewVC Help
Powered by ViewVC 1.1.5