source: project/release/4/skiplists/tags/0.7/skiplists.scm @ 27175

Last change on this file since 27175 was 27175, checked in by juergen, 9 years ago

removed dependency on records, define-record-type and
define-record-printer used

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