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

Contents of /flexichain/skiplist.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun Jan 27 06:05:37 2008 UTC (6 years, 2 months ago) by charmon
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +98 -98 lines
flexichain 1.4
 * replaced tabs with spaces
 * minor indentation and spacing whitespace fixes
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