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

Contents of /flexichain/flexichain.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Sun Oct 3 09:29:19 2010 UTC (3 years, 6 months ago) by rstrandh
Branch: MAIN
Changes since 1.8: +1 -0 lines
Added copyright 2010 to flexichain.lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5