source: project/release/4/skiplists/tags/0.6/skiplists.scm @ 27161

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

version 0.6 with restructured code (additional module

File size: 18.7 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: Aug 2, 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-library records contracts)
77
78(module %skiplists
79  (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 chicken
88    assert when unless keyword? optional
89    getter-with-setter print); get-output-string open-output-string)
90  (only data-structures list-of?)
91  (only extras random))
92
93;;;; skipnode ADT (hidden)
94
95(define skipnode-type (make-record-type 'skipnode '(item next)))
96
97(define make-skipnode
98  (record-constructor skipnode-type))
99
100(define skipnode? (record-predicate skipnode-type))
101
102(define skipnode-item
103  (record-accessor skipnode-type 'item))
104
105(define skip-next
106  (record-accessor skipnode-type 'next))
107
108(define (skipnode-links node)
109  (if (null? node)
110    0
111    (vector-length (skip-next node))))
112
113(define skipnode-next
114  (getter-with-setter
115    (lambda (node k)
116      (if (>= k (skipnode-links node))
117        '()
118        (vector-ref (skip-next node) k)))
119    (lambda (node k new)
120      (if (>= k (skipnode-links node))
121        (set! node new)
122        (vector-set! (skip-next node) k new)))))
123
124;;; insert node after cursor, which is another node
125(define (skipnode-insert! cursor newnode)
126  (let down ((k (- (skipnode-links newnode) 1)))
127    (unless (negative? k)
128      (let ((node (skipnode-next cursor k)))
129        (set! (skipnode-next newnode k) (skipnode-next node k))
130        (set! (skipnode-next node k) newnode)
131        (down (- k 1))))))
132
133;;; delete node after cursor, which is another node
134(define (skipnode-remove! cursor links)
135  (let down ((k (- links 1)))
136    (unless (negative? k)
137      (let ((node (skipnode-next cursor k)))
138        (set! (skipnode-next node k) (skipnode-next (skipnode-next node k) k))
139        (down (- k 1))))))
140
141;;;; skiplist ADT
142
143(define skip-type
144  (make-record-type 'skiplist
145    '(orders gap links count cursor start)))
146
147(define skiplist?  (record-predicate skip-type))
148
149(define skip-maker
150  (record-constructor skip-type))
151
152(define skip-orders (record-accessor skip-type 'orders))
153
154(define skip-gap (record-accessor skip-type 'gap))
155
156(define skip-count
157  (getter-with-setter (record-accessor skip-type 'count)
158                      (record-modifier skip-type 'count)))
159
160(define skip-links
161  (getter-with-setter (record-accessor skip-type 'links)
162                      (record-modifier skip-type 'links)))
163
164(define (skip-cursor skp)
165  (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp)))
166
167(define (skip-start skp)
168  (make-skipnode start: ((record-accessor skip-type 'start) skp)))
169
170(define (make-skiplist max-links . orders)
171  (apply make-skiplist-with-gap max-links 2 orders))
172
173(define (make-skiplist-with-gap max-links gap . orders)
174  (skip-maker orders gap 1 0
175              (make-vector max-links '())
176              (make-vector max-links '())))
177
178(define (make-skiplist-from-list lst max-links . orders)
179  (apply make-skiplist-with-gap-from-list lst max-links 2 orders))
180
181(define (make-skiplist-with-gap-from-list lst max-links gap . orders)
182  (let ((skp (apply make-skiplist-with-gap max-links gap orders)))
183    (let loop ((lst lst))
184      (unless (null? lst)
185        (skip-insert! skp (car lst))
186        (loop (cdr lst))))
187    skp))
188
189(define (skip-restructure skp max-links gap)
190  (let (
191    (result (apply make-skiplist-with-gap max-links gap (skip-orders skp)))
192    )
193    (let loop ((node (skipnode-next (skip-start skp) 0)))
194      (unless (null? node)
195        (skip-insert! result (skipnode-item node))
196        (loop (skipnode-next node 0))))
197    result))
198
199(define (skip-reorder skp . orders)
200  (let ((result (apply make-skiplist-with-gap
201                    (skip-max-links skp)
202                    (skip-gap skp)
203                    orders)))
204    (let loop ((node (skipnode-next (skip-start skp) 0)))
205      (unless (null? node)
206        (skip-insert! result (skipnode-item node))
207        (loop (skipnode-next node 0))))
208    result))
209
210(define (skip-for-each skp proc)
211  (let loop ((node (skipnode-next (skip-start skp) 0)))
212    (unless (null? node)
213      (proc (skipnode-item node))
214      (loop (skipnode-next node 0)))))
215
216(define (skip-filter skp ok?)
217  (let ((result (apply make-skiplist-with-gap
218                       (skip-max-links skp)
219                       (skip-gap skp)
220                       (skip-orders skp))))
221    (let loop ((node (skipnode-next (skip-start skp) 0)))
222      (unless (null? node)
223        (let ((item (skipnode-item node)))
224          (if (ok? item) (skip-insert! result item)))
225        (loop (skipnode-next node 0))))
226    result))
227
228(define (skip-list skp . ks)
229  (let ((k ;(if (null? ks) 0 (car ks))))
230           (optional ks 0)))
231    (let loop ((node (skipnode-next (skip-start skp) k)) (lst '()))
232      (if (null? node)
233        (reverse lst)
234        (loop (skipnode-next node k) (cons (skipnode-item node) lst))))))
235
236(define (skip-max-links skp)
237  (skipnode-links (skip-start skp)))
238
239(define (skip-dups? skp)
240  ;; more than one initial comparison operator
241  (not (null? (cdr (skip-orders skp)))))
242
243(define (skip-compare skp)
244  (let loop ((orders (skip-orders skp)))
245    (unless (null? orders)
246      (let ((cmp (car orders)) (rest (cdr orders)))
247        (if (null? rest)
248          cmp
249          (lambda (x y)
250            (if (zero? (cmp x y))
251              ((loop rest) x y)
252              (cmp x y))))))))
253
254(define (skip-search! skp item . flags)
255  (let ((lazy? (optional flags #t)) (cursor (skip-cursor skp)))
256    ; the lazy? argument is set to #f in skip-insert! to cope
257    ; with lists which are alreade sorted
258    (let down (
259      (k (- (skip-links skp) 1))
260      ;(node (skip-start skp))
261      (node (if (and lazy? (skip-lazy? skp item))
262              cursor
263              (skip-start skp)))
264      )
265      (unless (negative? k)
266        (let forward ((node node))
267          (let ((next (skipnode-next node k)))
268            (if (skip-in? skp item next)
269              (forward next)
270              (begin
271                (set! (skipnode-next cursor k) node)
272                (down (- k 1) node)))))))))
273
274(define (skip-found? skp item)
275  (let ((node (skipnode-next (skip-cursor skp) 0)))
276    (and (not (null? node))
277         (not (null? (skipnode-next node 0)))
278         (zero? ((skip-compare skp) item (skipnode-item (skipnode-next node 0)))))))
279
280(define (skip-lazy? skp item)
281  (let ((node (skipnode-next (skip-cursor skp) 0)))
282    (and (not (null? node))
283         (not (keyword? (skipnode-item node)))
284         (positive? ((skip-compare skp) item (skipnode-item node))))))
285
286(define (skip-in? skp item node)
287  (and (not (null? node))
288       (not (keyword? (skipnode-item node)))
289       (> ((skip-compare skp) item (skipnode-item node)) 0)))
290
291(define (skip-insert! skp item)
292  (skip-search! skp item #f)
293  (unless (and (not (skip-dups? skp)) (skip-found? skp item))
294    (let ((newlinks (skip-rand skp)) (links (skip-links skp)))
295      (if (> newlinks links)
296        (set! (skip-links skp) newlinks))
297      (skipnode-insert! (skip-cursor skp)
298                        (make-skipnode item (make-vector newlinks '())))
299      (set! (skip-count skp) (+ (skip-count skp) 1)))))
300
301(define (skip-remove! skp item)
302  (skip-search! skp item)
303  (when (skip-found? skp item)
304    (skipnode-remove! (skip-cursor skp) (skip-links skp))
305    (set! (skip-count skp) (- (skip-count skp) 1))))
306
307(define (skip-remove-all! skp item)
308  (skip-search! skp item)
309  (let loop ((found (skip-found? skp item)))
310    (when found
311      (skipnode-remove! (skip-cursor skp) (skip-links skp))
312      (set! (skip-count skp) (- (skip-count skp) 1))
313      (loop (skip-found? skp item)))))
314
315;;; to skip gap nodes at a time in the 2nd level (link index 1), one
316;;; out of every gap nodes must have at least 2 links. Iterating we
317;;; want one out of every gap^i nodes to have at least i+1 links.
318(define (skip-rand skp)
319  (let ((max-links (skip-max-links skp)))
320    (if (= max-links 1)
321      1 ; normal list, no randomization
322      (let* (
323        (gap (skip-gap skp))
324        (M (expt gap max-links))
325        (choice  (+ (random M) 1)) ; 0<=(random M)<M
326        )                          ; 1<=choice<=M
327        (assert (exact? M) "too many links in skip-rand" max-links)
328        (let loop ((links 1) (barrier (quotient M gap)))
329          (if (>= choice barrier)
330            links
331            (loop (+ links 1) (quotient barrier gap))))))))
332
333(define (dups x y)
334  0)
335
336) ; module %skiplists
337
338(module skiplists
339  (skiplists skiplist? make-skiplist make-skiplist-with-gap skip-compare
340             make-skiplist-from-list make-skiplist-with-gap-from-list
341             skip-search!  skip-insert! skip-remove! skip-list skip-gap skip-count
342             skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups
343             skip-restructure skip-for-each skip-orders skip-reorder
344             skip-filter)
345
346(import scheme
347  (prefix %skiplists %)
348  (only contracts doclist doclist->dispatcher contract define-with-contract)
349  (only chicken unless get-output-string open-output-string)
350  (only data-structures list-of?))
351
352;; initialize documentation
353(doclist '())
354
355;;;; skiplist ADT
356
357(define-with-contract (skiplist? xpr)
358  "type predicate"
359  (%skiplist? xpr))
360
361(define-with-contract (skip-orders skp)
362  "list of numerical comparison operators"
363  (domain (%skiplist? skp))
364  (range ((list-of? procedure?) result))
365  (%skip-orders skp))
366
367(define-with-contract (skip-gap skp)
368  "gap of skiplist"
369  (domain (%skiplist? skp))
370  (range (integer? result) (> result 1))
371  (%skip-gap skp))
372
373(define-with-contract (skip-count skp)
374  "number of nodes stored in skiplist"
375  (domain (%skiplist? skp))
376  (range (integer? result) (>= result 0))
377  (%skip-count skp))
378
379(define-with-contract (skip-links skp)
380  "maximal number of occupied links"
381  (domain (%skiplist? skp))
382  (range (integer? result) (>= (%skip-max-links skp) result 1))
383  (%skip-links skp))
384
385(define-with-contract (make-skiplist max-links . orders)
386  "skiplist constructor"
387  (domain (integer? max-links) (positive? max-links)
388          ((list-of? procedure?) orders)
389          (not (null? orders))
390          "numerical valued comparison procedures")
391  (range (%skiplist? result))
392  (apply %make-skiplist-with-gap max-links 2 orders))
393
394(define-with-contract (make-skiplist-with-gap max-links gap . orders)
395  "skiplist constructor with gap different from 2"
396  (domain (integer? max-links) (positive? max-links)
397          (integer? gap) (> gap 1)
398          ((list-of? procedure?) orders)
399          (not (null? orders))
400          "numerical valued comparison procedures")
401  (range (%skiplist? result))
402  (apply %make-skiplist-with-gap max-links gap orders))
403 
404(define-with-contract (make-skiplist-from-list lst max-links . orders)
405  "construct a skiplist from an ordinary list"
406  (domain (list? lst)
407          "list items must be comparable by operators in orders"
408          (integer? max-links) (positive? max-links)
409          ((list-of? procedure?) orders)
410          (not (null? orders))
411          "numerical valued comparison procedures")
412  (range (%skiplist? result))
413  (apply %make-skiplist-with-gap-from-list lst max-links 2 orders))
414
415(define-with-contract
416  (make-skiplist-with-gap-from-list lst max-links gap . orders)
417  "construct a skiplist with gap different from 2 from an ordinary list"
418  (domain (list? lst)
419          "list items must be comparable by operators in orders"
420          (integer? max-links) (positive? max-links)
421          (integer? gap) (> gap 1)
422          ((list-of? procedure?) orders)
423          (not (null? orders))
424          "numerical valued comparison procedures")
425  (range (%skiplist? result))
426  (apply %make-skiplist-with-gap-from-list lst max-links gap orders))
427
428(define-with-contract (skip-restructure skp max-links gap)
429  "restructure skiplist by changing max-links and gap"
430  (domain (integer? max-links) (positive? max-links)
431          (integer? gap) (> gap 1))
432  (range (%skiplist? result)
433         (= (%skip-max-links result) max-links)
434         (= (%skip-gap result) gap))
435  (%skip-restructure skp max-links gap))
436
437(define-with-contract (skip-reorder skp . orders)
438  "reorder skiplist by changing the order of comparison operators"
439  (domain (%skiplist? skp)
440          ((list-of? procedure?) orders)
441          (set-in? orders (%skip-orders skp))
442          (set-in? (%skip-orders skp) orders))
443  (range (%skiplist? result)
444         (= (%skip-count result) (%skip-count skp)))
445  (apply %skip-reorder skp orders))
446
447(define (set-in? lst1 lst2)
448  (let loop ((lst lst1))
449    (cond
450      ((null? lst) #t)
451      ((not (memq (car lst) lst2)) #f)
452      (else (loop (cdr lst))))))
453
454(define-with-contract (skip-for-each skp proc)
455  "apply proc to each item of skiplist"
456  (domain (%skiplist? skp)
457          (procedure? proc))
458  (%skip-for-each skp proc))
459
460(define-with-contract (skip-filter skp ok?)
461  "filter a skiplist according to predicate ok?"
462  (domain (%skiplist? skp)
463          (procedure? ok?)
464          "one argument predicate")
465  (range (%skiplist? result))
466  (%skip-filter skp ok?))
467
468(define-with-contract (skip-list skp . ks)
469  "map skiplist to an ordinary list (at link level k, if provided)"
470  (domain (%skiplist? skp) ((list-of? (lambda (k)
471                                       (and (integer? k)
472                                            (>= k 0)
473                                            (< k (%skip-max-links skp)))))
474                           ks))
475  (range (list? result))
476  (apply %skip-list skp ks))
477
478(define-with-contract (skip-max-links skp)
479  "maximal number of links"
480  (domain (%skiplist? skp))
481  (range (integer? result) (positive? result))
482  (%skip-max-links skp))
483
484(define-with-contract (skip-dups? skp)
485  "check if duplicates are allowed"
486  (domain (%skiplist? skp))
487  (%skip-dups? skp))
488
489(define-with-contract (skip-compare skp)
490  "combined numerical comparison procedure"
491  (domain (%skiplist? skp))
492  (range (procedure? result))
493  (%skip-compare skp))
494
495(define-with-contract (skip-search! skp item)
496  "move cursor to a place, where one can look for item"
497  (domain (%skiplist? skp))
498  (effect (count (%skip-count skp) count =)
499          (links (%skip-links skp) links =))
500  (%skip-search! skp item))
501 
502(define-with-contract (skip-found? skp item)
503  "check, if last skip-search! was successfull"
504  (domain (%skiplist? skp))
505  (range (boolean? result))
506  (%skip-found? skp item))
507
508(define-with-contract (skip-insert! skp . items)
509  "insert new nodes with items into skiplist"
510  (domain (%skiplist? skp))
511  (effect (count (%skip-count skp) (+ count (length items))
512                 (if (skip-dups? skp) = >=)))
513  (let loop ((items items))
514    (unless (null? items)
515      (%skip-insert! skp (car items))
516      (loop (cdr items)))))
517
518(define-with-contract (skip-remove! skp . items)
519  "remove nodes (one per found item) with items from skiplist"
520  (domain (%skiplist? skp))
521  (effect (count (%skip-count skp) (- count (length items)) <=))
522  (let loop ((items items))
523    (unless (null? items)
524    (%skip-remove! skp (car items))
525    (loop (cdr items)))))
526 
527(define-with-contract (skip-remove-all! skp . items)
528  "remove nodes (all per found item) with items from skiplist"
529  (domain (%skiplist? skp))
530  (effect (count (%skip-count skp) count >=))
531  (let loop ((items items))
532    (unless (null? items)
533    (%skip-remove-all! skp (car items))
534    (loop (cdr items)))))
535 
536(define-with-contract (dups x y)
537  "trivial numerical comparison operator to allow for duplicates"
538  0)
539
540;; save documentation
541(define skiplists (doclist->dispatcher (doclist)))
542
543) ; module skiplists
544
Note: See TracBrowser for help on using the repository browser.