source: project/release/4/skiplists/trunk/skiplists.scm @ 26761

Last change on this file since 26761 was 26761, checked in by juergen, 8 years ago

assert in skip-rand changed

File size: 18.0 KB
Line 
1
2; Copyright (c) 2011, Juergen Lorenz
3; All rights reserved.
4;
5; Redistribution and use in source and binary forms, with or without
6; modification, are permitted provided that the following conditions are
7; met:
8;
9; Redistributions of source code must retain the above copyright
10; notice, this list of conditions and the following disclaimer.
11;
12; Redistributions in binary form must reproduce the above copyright
13; notice, this list of conditions and the following disclaimer in the
14; documentation and/or other materials provided with the distribution.
15;
16; Neither the name of the author nor the names of its contributors may be
17; used to endorse or promote products derived from this software without
18; specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
26; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31;
32; Author: Juergen Lorenz
33;         ju (at) jugilo (dot) de
34;
35; Last update: May 21, 2012
36;
37;Rationale
38;=========
39;
40;Skiplists are data-types, which can replace balanced search-trees. They
41;are described by Sedgewick. The idea is as follows:
42;
43;Contrary to listnodes, which are pairs of an item and a next pointer,
44;skipnodes are pairs of an item and a vector of next pointers. The
45;length' of these vectors depend on each skipnode itself, they vary
46;between 1 and a predefind integer, max-links. An alternative to
47;balancing is achieved by some randomization in such a way, that, in the
48;average, the number of nodes with at least k links is half the number
49;of links with at least k-1 links, for k=1,...,max-links. Following the
50;next pointers at a fixed link-level, k say,  one skips all nodes with less
51;pointers than k.
52;
53;Inserting an item into a skiplist now works as follows.
54;First one packages the item into a skipnode, where the number of links
55;is generated in some randomized way.
56;Second, one follows the skiplist along the highest occupied number of
57;links as long as the skiplist's nodes have items less then the item of
58;the node to be inserted.
59;Third, one steps down one level and continues following the skiplist's
60;nodes at this new smaller level.
61;Repeating this process until level 0 is reached we eventually find the
62;place where our new node is to be inserted.
63;
64;Some additional remarks are in order.
65;
66;We described the process with a gap of two, i.e. at each level one node
67;of the level below is skipped.  Another value than two for the gap is
68;possible as well.
69;
70;We have to decide, what to do with duplicates. We choose the following
71;approach: The skilist itself stores a list of either one or several numerical
72;comparison operators. One means, duplicates are not allowed, several means,
73;that the nth operator resolves the remaining duplicates the operators
74;below n.
75;
76(require 'records 'contracts)
77
78(module skiplists
79  (skiplists skiplist? make-skiplist make-skiplist-with-gap skip-compare
80             make-skiplist-from-list make-skiplist-with-gap-from-list
81             skip-search!  skip-insert! skip-remove! skip-list skip-gap skip-count
82             skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups
83             skip-restructure skip-for-each skip-orders skip-reorder
84             skip-filter)
85
86(import scheme records
87  (only contracts doclist doclist->dispatcher contract define-with-contract)
88  (only chicken
89    assert when unless keyword? optional
90    getter-with-setter print get-output-string open-output-string)
91  (only data-structures list-of?)
92  (only extras random))
93
94;; initialize documentation
95(doclist '())
96
97;;;; skipnode ADT (hidden)
98
99(define skipnode-type (make-record-type 'skipnode '(item next)))
100
101(define make-skipnode
102  (record-constructor skipnode-type))
103
104(define skipnode? (record-predicate skipnode-type))
105
106(define skipnode-item
107  (record-accessor skipnode-type 'item))
108
109(define skip-next
110  (record-accessor skipnode-type 'next))
111
112(define (skipnode-links node)
113  (if (null? node)
114    0
115    (vector-length (skip-next node))))
116
117(define skipnode-next
118  (getter-with-setter
119    (lambda (node k)
120      (if (>= k (skipnode-links node))
121        '()
122        (vector-ref (skip-next node) k)))
123    (lambda (node k new)
124      (if (>= k (skipnode-links node))
125        (set! node new)
126        (vector-set! (skip-next node) k new)))))
127
128;;; insert node after cursor, which is another node
129(define (skipnode-insert! cursor newnode)
130  (let down ((k (- (skipnode-links newnode) 1)))
131    (unless (negative? k)
132      (let ((node (skipnode-next cursor k)))
133        (set! (skipnode-next newnode k) (skipnode-next node k))
134        (set! (skipnode-next node k) newnode)
135        (down (- k 1))))))
136
137;;; delete node after cursor, which is another node
138(define (skipnode-remove! cursor links)
139  (let down ((k (- links 1)))
140    (unless (negative? k)
141      (let ((node (skipnode-next cursor k)))
142        (set! (skipnode-next node k) (skipnode-next (skipnode-next node k) k))
143        (down (- k 1))))))
144
145;;;; skiplist ADT
146
147(define skip-type
148  (make-record-type 'skiplist
149    '(orders gap links count cursor start)))
150
151(define-with-contract (skiplist? xpr)
152  "type predicate"
153  (%skiplist? xpr))
154
155(define %skiplist?  (record-predicate skip-type))
156
157(define skip-maker
158  (record-constructor skip-type))
159
160(define-with-contract (skip-orders skp)
161  "list of numerical comparison operators"
162  (domain (%skiplist? skp))
163  (range ((list-of? procedure?) result))
164  (%skip-orders skp))
165
166(define %skip-orders (record-accessor skip-type 'orders))
167
168(define-with-contract (skip-gap skp)
169  "gap of skiplist"
170  (domain (%skiplist? skp))
171  (range (integer? result) (> result 1))
172  (%skip-gap skp))
173
174(define %skip-gap (record-accessor skip-type 'gap))
175 
176
177(define-with-contract (skip-count skp)
178  "number of nodes stored in skiplist"
179  (domain (%skiplist? skp))
180  (range (integer? result) (>= result 0))
181  (%skip-count skp))
182
183(define %skip-count
184  (getter-with-setter (record-accessor skip-type 'count)
185                      (record-modifier skip-type 'count)))
186
187(define-with-contract (skip-links skp)
188  "maximal number of occupied links"
189  (domain (%skiplist? skp))
190  (range (integer? result) (>= (%skip-max-links skp) result 1))
191  (%skip-links skp))
192
193(define %skip-links
194  (getter-with-setter (record-accessor skip-type 'links)
195                      (record-modifier skip-type 'links)))
196
197(define (skip-cursor skp)
198  (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp)))
199
200(define (skip-start skp)
201  (make-skipnode start: ((record-accessor skip-type 'start) skp)))
202
203(define-with-contract (make-skiplist max-links . orders)
204  "skiplist constructor"
205  (domain (integer? max-links) (positive? max-links)
206          ((list-of? procedure?) orders)
207          (not (null? orders))
208          "numerical valued comparison procedures")
209  (range (%skiplist? result))
210  (apply %make-skiplist-with-gap max-links 2 orders))
211
212(define-with-contract (make-skiplist-with-gap max-links gap . orders)
213  "skiplist constructor with gap different from 2"
214  (domain (integer? max-links) (positive? max-links)
215          (integer? gap) (> gap 1)
216          ((list-of? procedure?) orders)
217          (not (null? orders))
218          "numerical valued comparison procedures")
219  (range (%skiplist? result))
220  (apply %make-skiplist-with-gap max-links gap orders))
221 
222(define (%make-skiplist-with-gap max-links gap . orders)
223  (skip-maker orders gap 1 0
224              (make-vector max-links '())
225              (make-vector max-links '())))
226
227(define-with-contract (make-skiplist-from-list lst max-links . orders)
228  "construct a skiplist from an ordinary list"
229  (domain (list? lst)
230          "list items must be comparable by operators in orders"
231          (integer? max-links) (positive? max-links)
232          ((list-of? procedure?) orders)
233          (not (null? orders))
234          "numerical valued comparison procedures")
235  (range (%skiplist? result))
236  (apply %make-skiplist-with-gap-from-list lst max-links 2 orders))
237
238(define-with-contract
239  (make-skiplist-with-gap-from-list lst max-links gap . orders)
240  "construct a skiplist with gap different from 2 from an ordinary list"
241  (domain (list? lst)
242          "list items must be comparable by operators in orders"
243          (integer? max-links) (positive? max-links)
244          (integer? gap) (> gap 1)
245          ((list-of? procedure?) orders)
246          (not (null? orders))
247          "numerical valued comparison procedures")
248  (range (%skiplist? result))
249  (apply %make-skiplist-with-gap-from-list lst max-links gap orders))
250
251(define (%make-skiplist-with-gap-from-list lst max-links gap . orders)
252  (let ((skp (apply %make-skiplist-with-gap max-links gap orders)))
253    (let loop ((lst lst))
254      (unless (null? lst)
255        (%skip-insert! skp (car lst))
256        (loop (cdr lst))))
257    skp))
258
259(define-with-contract (skip-restructure skp max-links gap)
260  "restructure skiplist by changing max-links and gap"
261  (domain (integer? max-links) (positive? max-links)
262          (integer? gap) (> gap 1))
263  (range (%skiplist? result)
264         (= (%skip-max-links result) max-links)
265         (= (%skip-gap result) gap))
266  (%skip-restructure skp max-links gap))
267
268(define (%skip-restructure skp max-links gap)
269  (let (
270    (result (apply %make-skiplist-with-gap max-links gap (%skip-orders skp)))
271    )
272    (let loop ((node (skipnode-next (skip-start skp) 0)))
273      (unless (null? node)
274        (%skip-insert! result (skipnode-item node))
275        (loop (skipnode-next node 0))))
276    result))
277
278(define-with-contract (skip-reorder skp . orders)
279  "reorder skiplist by changing the order of comparison operators"
280  (domain (%skiplist? skp)
281          ((list-of? procedure?) orders)
282          (set-in? orders (%skip-orders skp))
283          (set-in? (%skip-orders skp) orders))
284  (range (%skiplist? result)
285         (= (%skip-count result) (%skip-count skp)))
286  (apply %skip-reorder skp orders))
287
288(define (%skip-reorder skp . orders)
289  (let ((result (apply %make-skiplist-with-gap
290                    (%skip-max-links skp)
291                    (%skip-gap skp)
292                    orders)))
293    (let loop ((node (skipnode-next (skip-start skp) 0)))
294      (unless (null? node)
295        (%skip-insert! result (skipnode-item node))
296        (loop (skipnode-next node 0))))
297    result))
298
299(define (set-in? lst1 lst2)
300  (let loop ((lst lst1))
301    (cond
302      ((null? lst) #t)
303      ((not (memq (car lst) lst2)) #f)
304      (else (loop (cdr lst))))))
305
306(define-with-contract (skip-for-each skp proc)
307  "apply proc to each item of skiplist"
308  (domain (%skiplist? skp)
309          (procedure? proc))
310  (%skip-for-each skp proc))
311
312(define (%skip-for-each skp proc)
313  (let loop ((node (skipnode-next (skip-start skp) 0)))
314    (unless (null? node)
315      (proc (skipnode-item node))
316      (loop (skipnode-next node 0)))))
317
318(define-with-contract (skip-filter skp ok?)
319  "filter a skiplist according to predicate ok?"
320  (domain (%skiplist? skp)
321          (procedure? ok?)
322          "one argument predicate")
323  (range (%skiplist? result))
324  (%skip-filter skp ok?))
325
326(define (%skip-filter skp ok?)
327  (let ((result (apply %make-skiplist-with-gap
328                       (%skip-max-links skp)
329                       (%skip-gap skp)
330                       (%skip-orders skp))))
331    (let loop ((node (skipnode-next (skip-start skp) 0)))
332      (unless (null? node)
333        (let ((item (skipnode-item node)))
334          (if (ok? item) (%skip-insert! result item)))
335        (loop (skipnode-next node 0))))
336    result))
337
338(define-with-contract (skip-list skp . ks)
339  "map skiplist to an ordinary list (at link level k, if provided)"
340  (domain (%skiplist? skp) ((list-of? (lambda (k)
341                                       (and (integer? k)
342                                            (>= k 0)
343                                            (< k (%skip-max-links skp)))))
344                           ks))
345  (range (list? result))
346  (apply %skip-list skp ks))
347
348(define (%skip-list skp . ks)
349  (let ((k ;(if (null? ks) 0 (car ks))))
350           (optional ks 0)))
351    (let loop ((node (skipnode-next (skip-start skp) k)) (lst '()))
352      (if (null? node)
353        (reverse lst)
354        (loop (skipnode-next node k) (cons (skipnode-item node) lst))))))
355
356(define-with-contract (skip-max-links skp)
357  "maximal number of links"
358  (domain (%skiplist? skp))
359  (range (integer? result) (positive? result))
360  (%skip-max-links skp))
361
362(define (%skip-max-links skp)
363  (skipnode-links (skip-start skp)))
364
365(define-with-contract (skip-dups? skp)
366  "check if duplicates are allowed"
367  (domain (%skiplist? skp))
368  (%skip-dups? skp))
369
370(define (%skip-dups? skp)
371  ;; more than one initial comparison operator
372  (not (null? (cdr (%skip-orders skp)))))
373
374(define-with-contract (skip-compare skp)
375  "combined numerical comparison procedure"
376  (domain (%skiplist? skp))
377  (range (procedure? result))
378  (%skip-compare skp))
379
380(define (%skip-compare skp)
381  (let loop ((orders (%skip-orders skp)))
382    (unless (null? orders)
383      (let ((cmp (car orders)) (rest (cdr orders)))
384        (if (null? rest)
385          cmp
386          (lambda (x y)
387            (if (zero? (cmp x y))
388              ((loop rest) x y)
389              (cmp x y))))))))
390
391(define-with-contract (skip-search! skp item)
392  "move cursor to a place, where one can look for item"
393  (domain (%skiplist? skp))
394  (effect (count (%skip-count skp) count =)
395          (links (%skip-links skp) links =))
396  (%skip-search! skp item))
397 
398(define (%skip-search! skp item . flags)
399  (let ((lazy? (optional flags #t)) (cursor (skip-cursor skp)))
400    ; the lazy? argument is set to #f in skip-insert! to cope
401    ; with lists which are alreade sorted
402    (let down (
403      (k (- (%skip-links skp) 1))
404      ;(node (skip-start skp))
405      (node (if (and lazy? (skip-lazy? skp item))
406              cursor
407              (skip-start skp)))
408      )
409      (unless (negative? k)
410        (let forward ((node node))
411;(print k " " (skipnode-item node))
412          (let ((next (skipnode-next node k)))
413            (if (skip-in? skp item next)
414              (forward next)
415              (begin
416                (set! (skipnode-next cursor k) node)
417                (down (- k 1) node)))))))))
418
419(define-with-contract (skip-found? skp item)
420  "check, if last skip-search! was successfull"
421  (domain (%skiplist? skp))
422  (range (boolean? result))
423  (%skip-found? skp item))
424
425(define (%skip-found? skp item)
426  (let ((node (skipnode-next (skip-cursor skp) 0)))
427    (and (not (null? node))
428         (not (null? (skipnode-next node 0)))
429         (zero? ((%skip-compare skp) item (skipnode-item (skipnode-next node 0)))))))
430
431(define (skip-lazy? skp item)
432  (let ((node (skipnode-next (skip-cursor skp) 0)))
433    (and (not (null? node))
434         (not (keyword? (skipnode-item node)))
435         (positive? ((%skip-compare skp) item (skipnode-item node))))))
436
437(define (skip-in? skp item node)
438  (and (not (null? node))
439       (not (keyword? (skipnode-item node)))
440       (> ((%skip-compare skp) item (skipnode-item node)) 0)))
441
442(define-with-contract (skip-insert! skp . items)
443  "insert new nodes with items into skiplist"
444  (domain (%skiplist? skp))
445  (effect (count (%skip-count skp) (+ count (length items))
446                 (if (skip-dups? skp) = >=)))
447  (let loop ((items items))
448    (unless (null? items)
449      (%skip-insert! skp (car items))
450      (loop (cdr items)))))
451
452(define (%skip-insert! skp item)
453  (%skip-search! skp item #f)
454  (unless (and (not (%skip-dups? skp)) (skip-found? skp item))
455    (let ((newlinks (skip-rand skp)) (links (%skip-links skp)))
456      (if (> newlinks links)
457        (set! (%skip-links skp) newlinks))
458      (skipnode-insert! (skip-cursor skp)
459                        (make-skipnode item (make-vector newlinks '())))
460      (set! (%skip-count skp) (+ (%skip-count skp) 1)))))
461
462(define-with-contract (skip-remove! skp . items)
463  "remove nodes (one per found item) with items from skiplist"
464  (domain (%skiplist? skp))
465  (effect (count (%skip-count skp) (- count (length items)) <=))
466  (let loop ((items items))
467    (unless (null? items)
468    (%skip-remove! skp (car items))
469    (loop (cdr items)))))
470 
471(define (%skip-remove! skp item)
472  (skip-search! skp item)
473  (when (skip-found? skp item)
474    (skipnode-remove! (skip-cursor skp) (%skip-links skp))
475    (set! (%skip-count skp) (- (%skip-count skp) 1))))
476
477(define-with-contract (skip-remove-all! skp . items)
478  "remove nodes (all per found item) with items from skiplist"
479  (domain (%skiplist? skp))
480  (effect (count (%skip-count skp) count >=))
481  (let loop ((items items))
482    (unless (null? items)
483    (%skip-remove-all! skp (car items))
484    (loop (cdr items)))))
485 
486(define (%skip-remove-all! skp item)
487  (skip-search! skp item)
488  (let loop ((found (skip-found? skp item)))
489    (when found
490      (skipnode-remove! (skip-cursor skp) (%skip-links skp))
491      (set! (%skip-count skp) (- (%skip-count skp) 1))
492      (loop (skip-found? skp item)))))
493
494;;; to skip gap nodes at a time in the 2nd level (link index 1), one
495;;; out of every gap nodes must have at least 2 links. Iterating we
496;;; want one out of every gap^i nodes to have at least i+1 links.
497(define (skip-rand skp)
498  (let ((max-links (%skip-max-links skp)))
499    (if (= max-links 1)
500      1 ; normal list, no randomization
501      (let* (
502        (gap (%skip-gap skp))
503        (M (expt gap max-links))
504        (choice  (+ (random M) 1)) ; 0<=(random M)<M
505        )                          ; 1<=choice<=M
506        (assert (exact? M) "too many links in skip-rand" max-links)
507        (let loop ((links 1) (barrier (quotient M gap)))
508          (if (>= choice barrier)
509            links
510            (loop (+ links 1) (quotient barrier gap))))))))
511
512(define-with-contract (dups x y)
513  "trivial numerical comparison operator to allow for duplicates"
514  0)
515
516;; save documentation
517(define skiplists (doclist->dispatcher (doclist)))
518
519) ; module skiplists
520
Note: See TracBrowser for help on using the repository browser.