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

Contents of /flexichain/skiplist.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Thu Feb 9 02:51:06 2006 UTC (8 years, 2 months ago) by rkreuter
Branch: MAIN
Branch point for: clnet
Initial revision
1 rkreuter 1.1 ;;; Skiplist
2     ;;; Skiplist data structure definition
3     ;;;
4     ;;; Copyright (C) 2004 Robert Strandh (strandh@labri.fr)
5     ;;;
6     ;;; This library is free software; you can redistribute it and/or
7     ;;; modify it under the terms of the GNU Lesser General Public
8     ;;; License as published by the Free Software Foundation; either
9     ;;; version 2.1 of the License, or (at your option) any later version.
10     ;;;
11     ;;; This library is distributed in the hope that it will be useful,
12     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14     ;;; Lesser General Public License for more details.
15     ;;;
16     ;;; You should have received a copy of the GNU Lesser General Public
17     ;;; License along with this library; if not, write to the Free Software
18     ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19    
20     (in-package :skiplist)
21    
22     (defclass skiplist ()
23     ((maxlevel :initarg :maxlevel :initform 25 :reader maxlevel)
24     (start :reader start)
25     (lessfun :initarg :lessfun :initform #'< :reader lessfun)
26     (current-maxlevel :initform -1 :accessor current-maxlevel)))
27    
28     (defmethod initialize-instance :after ((s skiplist) &rest args)
29     (declare (ignore args))
30     (with-slots (maxlevel start) s
31     (assert (plusp maxlevel))
32     (setf start (make-array (+ maxlevel 3) :initial-element nil))))
33    
34     (defmethod print-object ((s skiplist) stream)
35     (print-unreadable-object (s stream :type t)
36     (with-slots (start) s
37     (when (entry-next start 0)
38     (loop for entry = (entry-next start 0) then (entry-next entry 0)
39     do (format stream "(~W ~W) "
40     (entry-key entry)
41     (entry-obj entry))
42     until (last-entry-p start entry 0))))))
43    
44     (defun entry-obj (entry)
45     (aref entry 0))
46    
47     (defun (setf entry-obj) (obj entry)
48     (setf (aref entry 0) obj))
49    
50     (defun entry-key (entry)
51     (aref entry 1))
52    
53     (defun (setf entry-key) (key entry)
54     (setf (aref entry 1) key))
55    
56     (defun entry-next (entry level)
57     (aref entry (+ level 2)))
58    
59     (defun (setf entry-next) (next entry level)
60     (setf (aref entry (+ level 2)) next))
61    
62     (defun key-< (skiplist key1 key2)
63     (funcall (lessfun skiplist) key1 key2))
64    
65     (defun key-<= (skiplist key1 key2)
66     (not (funcall (lessfun skiplist) key2 key1)))
67    
68     (defun key-= (skiplist key1 key2)
69     (and (not (funcall (lessfun skiplist) key1 key2))
70     (not (funcall (lessfun skiplist) key2 key1))))
71    
72     (defun key-> (skiplist key1 key2)
73     (funcall (lessfun skiplist) key2 key1))
74    
75     (defun key->= (skiplist key1 key2)
76     (not (funcall (lessfun skiplist) key1 key2)))
77    
78     (defun last-entry-p (start entry level)
79     (eq (entry-next entry level) (entry-next start level)))
80    
81     (defun skiplist-empty-p (skiplist)
82     (= (slot-value skiplist 'current-maxlevel) -1))
83    
84     ;;; From a given entry return an entry such that the key of the
85     ;;; following one is the smallest one greater than or equal to the key
86     ;;; given; or the last element if no such element exists.
87    
88     (defun find-entry-level (skiplist entry level key)
89     (with-slots (start) skiplist
90     (loop until (or (key-= skiplist (entry-key (entry-next entry level)) key)
91     (and (key-< skiplist (entry-key entry) key)
92     (key-> skiplist (entry-key (entry-next entry level)) key))
93     (and (key-< skiplist (entry-key entry) key)
94     (key-< skiplist (entry-key (entry-next entry level)) key)
95     (last-entry-p start entry level)
96     (eq (entry-next entry level) (entry-next start level)))
97     (and (key-> skiplist (entry-key entry) key)
98     (key-> skiplist (entry-key (entry-next entry level)) key)
99     (last-entry-p start entry level)))
100     do (setf entry (entry-next entry level))))
101     entry)
102    
103    
104     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105     ;;;
106     ;;; Find
107    
108     (defun skiplist-find (skiplist key)
109     (when (skiplist-empty-p skiplist)
110     (return-from skiplist-find (values nil nil)))
111     (with-slots (current-maxlevel start) skiplist
112     (let ((entry (entry-next start current-maxlevel)))
113     (loop for l downfrom current-maxlevel to 0
114     do (setf entry (find-entry-level skiplist entry l key)))
115     (if (key-= skiplist (entry-key (entry-next entry 0)) key)
116     (values (entry-obj (entry-next entry 0)) t)
117     (values nil nil)))))
118    
119     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
120     ;;;
121     ;;; Find first
122    
123     (defun skiplist-find-first (skiplist)
124     (assert (not (skiplist-empty-p skiplist)))
125     (with-slots (start) skiplist
126     (values (entry-obj (entry-next start 0))
127     (entry-key (entry-next start 0)))))
128    
129     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130     ;;;
131     ;;; Insert
132    
133     (defun pick-a-level (maxlevel)
134     (loop for level from 0 to maxlevel
135     while (zerop (random 2))
136     finally (return level)))
137    
138     (defun make-entry (level key obj)
139     (let ((entry (make-array (+ level 3) :initial-element nil)))
140     (setf (aref entry 0) obj
141     (aref entry 1) key)
142     entry))
143    
144     (defun (setf skiplist-find) (obj skiplist key)
145     (with-slots (current-maxlevel start) skiplist
146     (if (second (multiple-value-list (skiplist-find skiplist key)))
147     (let ((entry (entry-next start current-maxlevel)))
148     (loop for l downfrom current-maxlevel to 0
149     do (setf entry (find-entry-level skiplist entry l key)))
150     (setf (entry-obj (entry-next entry 0)) obj))
151     (let* ((level (pick-a-level (maxlevel skiplist)))
152     (new-entry (make-entry level key obj)))
153     (loop for l downfrom level above current-maxlevel
154     do (setf (entry-next start l) new-entry
155     (entry-next new-entry l) new-entry))
156     (let ((entry (entry-next start current-maxlevel)))
157     (loop for l downfrom current-maxlevel above level
158     do (setf entry (find-entry-level skiplist entry l key)))
159     (loop for l downfrom (min level current-maxlevel) to 0
160     do (setf entry (find-entry-level skiplist entry l key))
161     (setf (entry-next new-entry l) (entry-next entry l)
162     (entry-next entry l) new-entry)
163     (when (key-< skiplist key (entry-key entry))
164     (setf (entry-next start l) new-entry))))
165     (setf current-maxlevel (max current-maxlevel level)))))
166     skiplist)
167    
168     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
169     ;;;
170     ;;; Delete
171    
172     (defun skiplist-delete (skiplist key)
173     (assert (second (multiple-value-list (skiplist-find skiplist key))))
174     (with-slots (current-maxlevel start) skiplist
175     (let ((entry (entry-next start current-maxlevel)))
176     (loop for l downfrom current-maxlevel to 0
177     do (setf entry (find-entry-level skiplist entry l key))
178     when (key-= skiplist (entry-key (entry-next entry l)) key)
179     do (cond ((key-= skiplist (entry-key entry) key)
180     (setf (entry-next start l) nil))
181     ((key-< skiplist (entry-key entry) key)
182     (setf (entry-next entry l)
183     (entry-next (entry-next entry l) l)))
184     (t (setf (entry-next entry l)
185     (entry-next (entry-next entry l) l))
186     (setf (entry-next start l)
187     (entry-next entry l)))))
188     (loop while (and (null (entry-next start current-maxlevel))
189     (>= current-maxlevel 0))
190     do (decf current-maxlevel))))
191     skiplist)
192    
193     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
194     ;;;
195     ;;; Slide keys
196    
197     (defun update-interval (skiplist entry to update-key)
198     (with-slots (start) skiplist
199     (flet ((update-entry (entry)
200     (setf (entry-key entry)
201     (funcall update-key (entry-key entry) (entry-obj entry)))))
202     (loop while (key-<= skiplist (entry-key entry) to)
203     do (update-entry entry)
204     until (last-entry-p start entry 0)
205     do (setf entry (entry-next entry 0))))))
206    
207     (defun skiplist-slide-keys (skiplist from to update-key)
208     (unless (skiplist-empty-p skiplist)
209     (with-slots (current-maxlevel start) skiplist
210     (let ((entry (entry-next start current-maxlevel)))
211     (loop for l downfrom current-maxlevel to 0
212     do (setf entry (find-entry-level skiplist entry l from)))
213     (when (key->= skiplist (entry-key (entry-next entry 0)) from)
214     (update-interval skiplist (entry-next entry 0) to update-key)))))
215     skiplist)
216    
217     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
218     ;;;
219     ;;; Rotate prefix
220    
221     (defun skiplist-rotate-prefix (skiplist to update-key)
222     (unless (skiplist-empty-p skiplist)
223     (with-slots (current-maxlevel start) skiplist
224     (let ((entry (entry-next start current-maxlevel)))
225     (loop for l downfrom current-maxlevel to 0
226     do (setf entry (find-entry-level skiplist entry l to)))
227     (when (key-= skiplist (entry-key (entry-next entry 0)) to)
228     (setf entry (entry-next entry 0)))
229     (cond ((and (key-> skiplist (entry-key entry) to)
230     (key-> skiplist (entry-key (entry-next entry 0)) to))
231     nil)
232     ((and (key-<= skiplist (entry-key entry) to)
233     (key-<= skiplist (entry-key (entry-next entry 0)) to))
234     (update-interval skiplist (entry-next entry 0) to update-key))
235     (t (update-interval skiplist (entry-next start 0) to update-key)
236     (loop with entry = (entry-next entry 0)
237     for level from 0 to current-maxlevel
238     do (loop until (>= (length entry) (+ 3 level))
239     do (setf entry (entry-next entry (1- level))))
240     (setf (entry-next start level) entry)))))))
241     skiplist)
242    
243    
244     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245     ;;;
246     ;;; Rotate suffix
247    
248     (defun update-interval-to-end (skiplist entry update-key)
249     (with-slots (start) skiplist
250     (flet ((update-entry (entry)
251     (setf (entry-key entry)
252     (funcall update-key (entry-key entry) (entry-obj entry)))))
253     (loop do (update-entry entry)
254     until (last-entry-p start entry 0)
255     do (setf entry (entry-next entry 0))))))
256    
257     (defun skiplist-rotate-suffix (skiplist from update-key)
258     (unless (skiplist-empty-p skiplist)
259     (with-slots (current-maxlevel start) skiplist
260     (let ((entry (entry-next start current-maxlevel)))
261     (loop for l downfrom current-maxlevel to 0
262     do (setf entry (find-entry-level skiplist entry l from)))
263     (cond ((and (key-< skiplist (entry-key entry) from)
264     (key-< skiplist (entry-key (entry-next entry 0)) from))
265     nil)
266     ((and (key->= skiplist (entry-key entry) from)
267     (key->= skiplist (entry-key (entry-next entry 0)) from))
268     (update-interval-to-end skiplist (entry-next entry 0) update-key))
269     (t (update-interval-to-end skiplist (entry-next entry 0) update-key)
270     (loop with entry = (entry-next entry 0)
271     for level from 0 to current-maxlevel
272     do (loop until (>= (length entry) (+ 3 level))
273     do (setf entry (entry-next entry (1- level))))
274     (setf (entry-next start level) entry)))))))
275     skiplist)

  ViewVC Help
Powered by ViewVC 1.1.5