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

Contents of /flexichain/flexichain.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show 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 ;;; 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 ((fill-element :initarg :fill-element)
26 (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 &key initial-contents (element-type t))
32 (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 (with-slots (fill-element) chain
42 (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 (typep x element-type))
49 '(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 (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 (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 (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 (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 min-size))))
160
161 (defmethod initialize-instance :after ((chain standard-flexichain)
162 &rest initargs
163 &key
164 initial-contents
165 (element-type t)
166 (initial-nb-elements 0)
167 (initial-element nil))
168 (declare (ignore initargs))
169 ;; Initialize slots
170 (with-slots (fill-element buffer) chain
171 (let* ((data-length (if (> (length initial-contents) initial-nb-elements)
172 (length initial-contents)
173 initial-nb-elements))
174 (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 (setf buffer
179 (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
198 (defmacro with-virtual-gap ((bl ds gs ge) chain &body body)
199 (let ((c (gensym)))
200 `(let* ((,c ,chain)
201 (,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 (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 (incf index (- ge gs)))
224 (when (>= index bl)
225 (decf index bl))
226 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 (with-slots (buffer gap-start) chain
249 (assert (<= 0 position (nb-elements chain)) ()
250 'flexi-position-error :chain chain :position position)
251 (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 (with-slots (buffer gap-start) chain
260 (assert (<= 0 position (nb-elements chain)) ()
261 'flexi-position-error :chain chain :position position)
262 (ensure-gap-position chain position)
263 (ensure-room chain (+ (nb-elements chain) (length vector)))
264 (loop for elem across vector
265 do (setf (aref buffer gap-start) elem)
266 (incf gap-start)
267 (when (= gap-start (length buffer))
268 (setf gap-start 0)))))
269
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 (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor))))
281 (decrease-buffer-size chain))))
282
283 (defmethod delete-elements* ((chain standard-flexichain) position n)
284 (unless (zerop n)
285 (with-slots (buffer expand-factor min-size gap-end data-start) chain
286 (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 ;; 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 (setf gap-end surplus-elements))))
302 (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 (defmethod element* ((chain standard-flexichain) position)
309 (with-slots (buffer) chain
310 (assert (< -1 position (nb-elements chain)) ()
311 'flexi-position-error :chain chain :position position)
312 (aref buffer (position-index chain position))))
313
314 (defmethod (setf element*) (object (chain standard-flexichain) position)
315 (with-slots (buffer) chain
316 (assert (< -1 position (nb-elements chain)) ()
317 'flexi-position-error :chain chain :position position)
318 (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 (prog1
328 (element* chain 0)
329 (delete* chain 0)))
330
331 (defmethod pop-end ((chain standard-flexichain))
332 (let ((position (1- (nb-elements chain))))
333 (prog1
334 (element* chain position)
335 (delete* chain position))))
336
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 ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain))))
341 (t nil))))
342
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 (- rotated-gap-end count) (- gap-start count) gap-start)
462 (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 (- gap-end count) (- rotated-gap-start count) rotated-gap-start)
476 (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 fill-element expand-factor) fc
504 (let ((buffer-size (length buffer))
505 (buffer-after (make-array new-buffer-size
506 :element-type (array-element-type buffer)
507 :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