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

Contents of /flexichain/flexichain.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Tue Oct 17 16:02:02 2006 UTC (7 years, 6 months ago) by rstrandh
Branch: MAIN
Changes since 1.1: +6 -0 lines
Patches to make weak pointers work on a number of platforms.

Thanks to Luís Oliveira.
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     ((element-type :initarg :element-type :initform t)
26     (fill-element :initarg :fill-element)
27     (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     &key initial-contents)
33     (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     (with-slots (element-type fill-element) chain
43     (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     (typep x (slot-value chain 'element-type)))
50     '(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     (defgeneric element* (chain position)
115     (:documentation "Returns the element at POSITION of the chain.
116     If POSITION is out of range (less than 0 or greater than or equal
117     to the length of CHAIN, the FLEXI-POSITION-ERROR condition
118     will be signaled."))
119    
120     (defgeneric (setf element*) (object chain position)
121     (:documentation "Replaces the element at POSITION of CHAIN by OBJECT.
122     If POSITION if out of range (less than 0 or greater than or equal to
123     the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled."))
124    
125     (defgeneric push-start (chain object)
126     (:documentation "Inserts an object at the beginning of CHAIN."))
127    
128     (defgeneric push-end (chain object)
129     (:documentation "Inserts an object at the end of CHAIN."))
130    
131     (defgeneric pop-start (chain)
132     (:documentation "Pops and returns the element at the beginning of CHAIN."))
133    
134     (defgeneric pop-end (chain)
135     (:documentation "Pops and returns the element at the end of CHAIN."))
136    
137     (defgeneric rotate (chain &optional n)
138     (:documentation "Rotates the elements of CHAIN so that the element
139     that used to be at position N is now at position 0. With a negative
140     value of N, rotates the elements so that the element that used to be
141     at position 0 is now at position N."))
142    
143     (defclass standard-flexichain (flexichain)
144     ((buffer)
145     (gap-start)
146     (gap-end)
147     (data-start))
148     (:documentation "The standard instantiable subclass of FLEXICHAIN."))
149    
150     (defun required-space (chain nb-elements)
151     (with-slots (min-size expand-factor) chain
152     (+ 2 (max (ceiling (* nb-elements expand-factor))
153     min-size))))
154    
155     (defmethod initialize-instance :after ((chain standard-flexichain)
156     &rest initargs
157     &key initial-contents)
158     (declare (ignore initargs))
159     ;; Check initial-contents if provided
160     (unless (null initial-contents)
161     (with-slots (element-type) chain
162     (multiple-value-bind (offending-element foundp)
163     (find-if-2 (lambda (x)
164     (not (typep x element-type)))
165     initial-contents)
166     (assert (not foundp) ()
167     'flexi-initialization-error
168     :cause (format nil "Initial element ~A not of type ~S."
169     offending-element element-type)))))
170     ;; Initialize slots
171     (with-slots (element-type fill-element buffer) chain
172     (let* ((data-length (length initial-contents))
173     (size (required-space chain data-length))
174     (fill-size (- size data-length 2))
175     (sentinel-list (make-list 2 :initial-element fill-element))
176     (fill-list (make-list fill-size :initial-element fill-element)))
177     (setf buffer
178     (make-array size
179     :element-type element-type
180     :initial-contents (concatenate 'list
181     sentinel-list
182     initial-contents
183     fill-list)))))
184     (with-slots (gap-start gap-end data-start) chain
185     (setf gap-start (+ 2 (length initial-contents))
186     gap-end 0
187     data-start 1)))
188    
189     (defmacro with-virtual-gap ((bl ds gs ge) chain &body body)
190     (let ((c (gensym)))
191     `(let* ((,c ,chain)
192     (,bl (length (slot-value ,c 'buffer)))
193     (,ds (slot-value ,c 'data-start))
194     (,gs (slot-value ,c 'gap-start))
195     (,ge (slot-value ,c 'gap-end)))
196     (declare (ignorable ,bl ,ds ,gs ,ge))
197     (when (< ,gs ,ds) (incf ,gs ,bl))
198     (when (< ,ge ,ds) (incf ,ge ,bl))
199     ,@body)))
200    
201     (defmethod nb-elements ((chain standard-flexichain))
202     (with-virtual-gap (bl ds gs ge) chain
203     (- bl (- ge gs) 2)))
204    
205     (defmethod flexi-empty-p ((chain standard-flexichain))
206     (zerop (nb-elements chain)))
207    
208     (defun position-index (chain position)
209     "Returns the (0 indexed) index of the POSITION-th element
210     of the CHAIN in the buffer."
211     (with-virtual-gap (bl ds gs ge) chain
212     (let ((index (+ ds position 1)))
213     (when (>= index gs)
214     (incf index (- ge gs)))
215     (when (>= index bl)
216     (decf index bl))
217     index)))
218    
219     (defun index-position (chain index)
220     "Returns the position corresponding to the INDEX in the CHAIN.
221     Note: the result is undefined if INDEX is not the index of a valid
222     element of the CHAIN."
223     (with-virtual-gap (bl ds gs ge) chain
224     (when (< index ds)
225     (incf index bl))
226     (when (>= index ge)
227     (decf index (- ge gs)))
228     (- index ds 1)))
229    
230     (defun ensure-gap-position (chain position)
231     (move-gap chain (position-index chain position)))
232    
233     (defun ensure-room (chain nb-elements)
234     (with-slots (buffer) chain
235     (when (> nb-elements (- (length buffer) 2))
236     (increase-buffer-size chain nb-elements))))
237    
238     (defmethod insert* ((chain standard-flexichain) position object)
239     (with-slots (element-type buffer gap-start) chain
240     (assert (<= 0 position (nb-elements chain)) ()
241     'flexi-position-error :chain chain :position position)
242     (assert (typep object element-type) ()
243     'flexi-incompatible-type-error :element object :chain chain)
244     (ensure-gap-position chain position)
245     (ensure-room chain (1+ (nb-elements chain)))
246     (setf (aref buffer gap-start) object)
247     (incf gap-start)
248     (when (= gap-start (length buffer))
249     (setf gap-start 0))))
250    
251     (defmethod insert-vector* ((chain standard-flexichain) position vector)
252     (with-slots (element-type buffer gap-start) chain
253     (assert (<= 0 position (nb-elements chain)) ()
254     'flexi-position-error :chain chain :position position)
255     (assert (typep (array-element-type vector) element-type) ()
256     'flexi-incompatible-type-error :element vector :chain chain)
257     (ensure-gap-position chain position)
258     (ensure-room chain (+ (nb-elements chain) (length vector)))
259     (loop for elem across vector
260     do (setf (aref buffer gap-start) elem)
261     (incf gap-start)
262     (when (= gap-start (length buffer))
263     (setf gap-start 0)))))
264    
265     (defmethod delete* ((chain standard-flexichain) position)
266     (with-slots (buffer expand-factor min-size fill-element gap-end) chain
267     (assert (< -1 position (nb-elements chain)) ()
268     'flexi-position-error :chain chain :position position)
269     (ensure-gap-position chain position)
270     (setf (aref buffer gap-end) fill-element)
271     (incf gap-end)
272     (when (= gap-end (length buffer))
273     (setf gap-end 0))
274     (when (and (> (length buffer) (+ min-size 2))
275     (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor))))
276     (decrease-buffer-size chain))))
277    
278     (defmethod element* ((chain standard-flexichain) position)
279     (with-slots (buffer) chain
280     (assert (< -1 position (nb-elements chain)) ()
281     'flexi-position-error :chain chain :position position)
282     (aref buffer (position-index chain position))))
283    
284     (defmethod (setf element*) (object (chain standard-flexichain) position)
285     (with-slots (buffer element-type) chain
286     (assert (< -1 position (nb-elements chain)) ()
287     'flexi-position-error :chain chain :position position)
288     (assert (typep object element-type) ()
289     'flexi-incompatible-type-error :chain chain :element object)
290     (setf (aref buffer (position-index chain position)) object)))
291    
292     (defmethod push-start ((chain standard-flexichain) object)
293     (insert* chain 0 object))
294    
295     (defmethod push-end ((chain standard-flexichain) object)
296     (insert* chain (nb-elements chain) object))
297    
298     (defmethod pop-start ((chain standard-flexichain))
299     (prog1 (element* chain 0)
300     (delete* chain 0)))
301    
302     (defmethod pop-end ((chain standard-flexichain))
303     (let ((position (1- (nb-elements chain))))
304     (prog1 (element* chain position)
305     (delete* chain position))))
306    
307     (defmethod rotate ((chain standard-flexichain) &optional (n 1))
308     (when (> (nb-elements chain) 1)
309     (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain))))
310     ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain))))
311     (t nil))))
312    
313     (defun move-gap (chain hot-spot)
314     "Moves the elements and gap inside the buffer so that
315     the element currently at HOT-SPOT becomes the first element following
316     the gap, or does nothing if there are no elements."
317     (with-slots (gap-start gap-end) chain
318     (unless (= hot-spot gap-end)
319     (case (gap-location chain)
320     (:gap-empty (move-empty-gap chain hot-spot))
321     (:gap-left (move-left-gap chain hot-spot))
322     (:gap-right (move-right-gap chain hot-spot))
323     (:gap-middle (move-middle-gap chain hot-spot))
324     (:gap-non-contiguous (move-non-contiguous-gap chain hot-spot))))
325     (values gap-start gap-end)))
326    
327     (defun move-empty-gap (chain hot-spot)
328     "Moves the gap. Handles the case where the gap is empty."
329     (with-slots (gap-start gap-end) chain
330     (setf gap-start hot-spot
331     gap-end hot-spot)))
332    
333     (defun move-left-gap (chain hot-spot)
334     "Moves the gap. Handles the case where the gap is
335     on the left of the buffer."
336     (with-slots (buffer gap-start gap-end data-start) chain
337     (let ((buffer-size (length buffer)))
338     (cond ((< (- hot-spot gap-end) (- buffer-size hot-spot))
339     (push-elements-left chain (- hot-spot gap-end)))
340     ((<= (- buffer-size hot-spot) gap-end)
341     (hop-elements-left chain (- buffer-size hot-spot)))
342     (t
343     (hop-elements-left chain (- gap-end gap-start))
344     (push-elements-right chain (- gap-start hot-spot)))))))
345    
346     (defun move-right-gap (chain hot-spot)
347     "Moves the gap. Handles the case where the gap is
348     on the right of the buffer."
349     (with-slots (buffer gap-start gap-end) chain
350     (let ((buffer-size (length buffer)))
351     (cond ((< (- gap-start hot-spot) hot-spot)
352     (push-elements-right chain (- gap-start hot-spot)))
353     ((<= hot-spot (- buffer-size gap-start))
354     (hop-elements-right chain hot-spot))
355     (t
356     (hop-elements-right chain (- buffer-size gap-start))
357     (push-elements-left chain (- hot-spot gap-end)))))))
358    
359     (defun move-middle-gap (chain hot-spot)
360     "Moves the gap. Handles the case where the gap is
361     in the middle of the buffer."
362     (with-slots (buffer gap-start gap-end) chain
363     (let ((buffer-size (length buffer)))
364     (cond ((< hot-spot gap-start)
365     (cond ((<= (- gap-start hot-spot)
366     (+ (- buffer-size gap-end) hot-spot))
367     (push-elements-right chain (- gap-start hot-spot)))
368     (t
369     (push-elements-left chain (- buffer-size gap-end))
370     (move-right-gap chain hot-spot))))
371     (t
372     (cond ((< (- hot-spot gap-end)
373     (+ (- buffer-size hot-spot) gap-start))
374     (push-elements-left chain (- hot-spot gap-end)))
375     (t
376     (push-elements-right chain gap-start)
377     (move-left-gap chain hot-spot))))))))
378    
379     (defun move-non-contiguous-gap (chain hot-spot)
380     "Moves the gap. Handles the case where the gap is in 2 parts,
381     on both ends of the buffer."
382     (with-slots (buffer gap-start gap-end) chain
383     (let ((buffer-size (length buffer)))
384     (cond ((< (- hot-spot gap-end) (- gap-start hot-spot))
385     (hop-elements-right chain (min (- buffer-size gap-start)
386     (- hot-spot gap-end)))
387     (let ((nb-left (- hot-spot gap-end)))
388     (unless (zerop nb-left)
389     (push-elements-left chain nb-left))))
390     (t
391     (hop-elements-left chain (min gap-end (- gap-start hot-spot)))
392     (let ((nb-right (- gap-start hot-spot)))
393     (unless (zerop nb-right)
394     (push-elements-right chain nb-right))))))))
395    
396     (defgeneric move-elements (standard-flexichain to from start1 start2 end2)
397     (:documentation "move elements of a flexichain and adjust data-start"))
398    
399     (defmethod move-elements ((fc standard-flexichain) to from start1 start2 end2)
400     (replace to from :start1 start1 :start2 start2 :end2 end2)
401     (with-slots (data-start) fc
402     (when (and (<= start2 data-start) (< data-start end2))
403     (incf data-start (- start1 start2)))))
404    
405     (defgeneric fill-gap (standard-flexichain start end)
406     (:documentation "fill part of gap with the fill element"))
407    
408     (defmethod fill-gap ((fc standard-flexichain) start end)
409     (with-slots (buffer fill-element) fc
410     (fill buffer fill-element :start start :end end)))
411    
412     (defun push-elements-left (chain count)
413     "Pushes the COUNT elements of CHAIN at the right of the gap,
414     to the beginning of the gap. The gap must be continuous. Example:
415     PUSH-ELEMENTS-LEFT abcd-----efghijklm 2 => abcdef-----ghijklm"
416     (with-slots (buffer gap-start gap-end) chain
417     (move-elements chain buffer buffer gap-start gap-end (+ gap-end count))
418     (fill-gap chain (max gap-end (+ gap-start count)) (+ gap-end count))
419     (incf gap-start count)
420     (incf gap-end count)
421     (normalize-indices chain)))
422    
423     (defun push-elements-right (chain count)
424     "Pushes the COUNT elements of CHAIN at the left of the gap,
425     to the end of the gap. The gap must be continuous. Example:
426     PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2 => ab-----cdefghijklm"
427     (with-slots (buffer gap-start gap-end) chain
428     (let* ((buffer-size (length buffer))
429     (rotated-gap-end (if (zerop gap-end) buffer-size gap-end)))
430     (move-elements chain buffer buffer
431     (- rotated-gap-end count) (- gap-start count) gap-start)
432     (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count)))
433     (decf gap-start count)
434     (setf gap-end (- rotated-gap-end count))
435     (normalize-indices chain))))
436    
437     (defun hop-elements-left (chain count)
438     "Moves the COUNT rightmost elements to the end of the gap,
439     on the left of the data. Example:
440     HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2 => -lmabcdefghijk-----"
441     (with-slots (buffer gap-start gap-end) chain
442     (let* ((buffer-size (length buffer))
443     (rotated-gap-start (if (zerop gap-start) buffer-size gap-start)))
444     (move-elements chain buffer buffer
445     (- gap-end count) (- rotated-gap-start count) rotated-gap-start)
446     (fill-gap chain (- rotated-gap-start count) rotated-gap-start)
447     (setf gap-start (- rotated-gap-start count))
448     (decf gap-end count)
449     (normalize-indices chain))))
450    
451     (defun hop-elements-right (chain count)
452     "Moves the COUNT leftmost elements to the beginning of the gap,
453     on the right of the data. Example:
454     HOP-ELEMENTS-RIGHT ---abcdefghijklm--- 2 => -----cdefghijklmab-"
455     (with-slots (buffer gap-start gap-end) chain
456     (move-elements chain buffer buffer gap-start gap-end (+ gap-end count))
457     (fill-gap chain gap-end (+ gap-end count))
458     (incf gap-start count)
459     (incf gap-end count)
460     (normalize-indices chain)))
461    
462     (defun increase-buffer-size (chain nb-elements)
463     (resize-buffer chain (required-space chain nb-elements)))
464    
465     (defun decrease-buffer-size (chain)
466     (resize-buffer chain (required-space chain (nb-elements chain))))
467    
468     (defgeneric resize-buffer (standard-flexichain new-buffer-size)
469     (:documentation "allocate a new buffer with the size indicated"))
470    
471     (defmethod resize-buffer ((fc standard-flexichain) new-buffer-size)
472     (with-slots (buffer gap-start gap-end
473     fill-element element-type expand-factor) fc
474     (let ((buffer-size (length buffer))
475     (buffer-after (make-array new-buffer-size
476     :element-type element-type
477     :initial-element fill-element)))
478     (case (gap-location fc)
479     ((:gap-empty :gap-middle)
480     (move-elements fc buffer-after buffer 0 0 gap-start)
481     (let ((gap-end-after (- new-buffer-size (- buffer-size gap-end))))
482     (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size)
483     (setf gap-end gap-end-after)))
484     (:gap-right
485     (move-elements fc buffer-after buffer 0 0 gap-start))
486     (:gap-left
487     (let ((gap-end-after (- new-buffer-size (+ 2 (nb-elements fc)))))
488     (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size)
489     (setf gap-end gap-end-after)))
490     (:gap-non-contiguous
491     (move-elements fc buffer-after buffer 0 gap-end gap-start)
492     (decf gap-start gap-end)
493     (setf gap-end 0)))
494     (setf buffer buffer-after)))
495     (normalize-indices fc))
496    
497     (defun normalize-indices (chain)
498     "Sets gap limits to 0 if they are at the end of the buffer."
499     (with-slots (buffer gap-start gap-end data-start) chain
500     (let ((buffer-size (length buffer)))
501     (when (>= data-start buffer-size)
502     (setf data-start 0))
503     (when (>= gap-start buffer-size)
504     (setf gap-start 0))
505     (when (>= gap-end buffer-size)
506     (setf gap-end 0)))))
507    
508     (defun gap-location (chain)
509     "Returns a keyword indicating the general location of the gap."
510     (with-slots (buffer gap-start gap-end) chain
511     (cond ((= gap-start gap-end) :gap-empty)
512     ((and (zerop gap-start) (>= gap-end 0)) :gap-left)
513     ((and (zerop gap-end) (> gap-start 0)) :gap-right)
514     ((> gap-end gap-start) :gap-middle)
515     (t :gap-non-contiguous))))
516    

  ViewVC Help
Powered by ViewVC 1.1.5