source: project/release/5/skiplists/tags/1.0/skiplists.scm @ 37472

Last change on this file since 37472 was 37472, checked in by juergen, 19 months ago

skiplists ported from chicken-4

File size: 28.1 KB
Line 
1; Copyright (c) 2011-2019, Juergen Lorenz
2; All rights reserved.
3;
4; Redistribution and use in source and binary forms, with or without
5; modification, are permitted provided that the following conditions are
6; met:
7;
8; Redistributions of source code must retain the above copyright
9; notice, this list of conditions and the following disclaimer.
10;
11; Redistributions in binary form must reproduce the above copyright
12; notice, this list of conditions and the following disclaimer in the
13; documentation and/or other materials provided with the distribution.
14;
15; Neither the name of the author nor the names of its contributors may be
16; used to endorse or promote products derived from this software without
17; specific prior written permission.
18;
19; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
20; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
21; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
22; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
23; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
24; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
25; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
26; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
27; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30;
31; Author: Juergen Lorenz
32;         ju (at) jugilo (dot) de
33;
34; Last update: Mar 25, 2019
35;
36;Rationale
37;=========
38;
39;Skiplists are data-types, which can replace balanced search-trees. They
40;are invented by Pugh. The idea is as follows:
41;
42;Contrary to listnodes, which are pairs of an item and a next pointer,
43;skipnodes are pairs of an item and a vector of next pointers. The
44;length' of these vectors depend on each skipnode itself. They are
45;choosen randomly in such a way, that, in the average, the number of
46;nodes with at least k links is half the number of links with at least
47;k-1 links, for k>1. Following the next pointers at a fixed link-level,
48;k say, one skips all nodes with less than k pointers.
49;
50;Inserting an item into a skiplist now works as follows.
51;First one packages the item into a skipnode, where the number of links
52;is generated randomly as described above.
53;Second, one follows the skiplist along the highest occupied number of
54;links as long as the skiplist's nodes point to items less then the item
55;of the node to be inserted.
56;Third, one steps down one level and continues following the skiplist's
57;nodes at this new smaller level.
58;Repeating this process until level 0 is reached we eventually find the
59;place where our new node is to be inserted.
60;
61;Some additional remarks are in order.
62;
63;We described the process with a width of two, i.e. at each level in the
64;average one node of the level below is skipped.  A higher value than two
65;for the width is possible as well, trading performance against space.
66;
67;We have to decide, what to do with duplicates. We choose the following
68;approach: The skiplist itself stores a list of either one or several numerical
69;comparison operators. Only if the last of those operators is the special
70;comparison operator dups (which returns constantly 0, i.e. it compares
71;nothing) duplicates are allowed. Moreover, we arrage matters in such a
72;way, that all nodes of duplicates with the same key have the same
73;height, so that a search for the item which was inserted last will be
74;found first.
75
76
77(module %skiplists
78  (skiplists skiplist skiplist? skiplist->list sl-null?
79   sl-item? sl-found?  sl-dups? sl-insert! sl-remove!
80   sl-clear! sl-search! sl-orders
81   sl-compare sl-width sl-height
82   sl-found sl-filter sl-map
83   sl-for-each sl-reorder sl-restructure
84   sl-count sl-search-level sl-min
85   sl-max sl-max-height dups) 
86
87(import scheme
88  (only (chicken base)
89        define-record-type define-record-printer optional when unless
90        case-lambda void identity list-of? gensym vector-resize
91        getter-with-setter setter print error)
92  (only (chicken condition) condition-case)
93  (only (chicken fixnum) fx+ fx- fx>= fx> fx< fx= fxmin)
94  (only (chicken format) format)
95  (only (chicken random) pseudo-random-integer))
96
97(define-syntax do-while ; hidden
98  (syntax-rules ()
99    ((_ test? xpr xpr1 ...)
100     (let loop ()
101       (if test?
102         (begin
103           xpr xpr1 ...
104           (loop)))))))
105
106;; trivial comparison operator to allow duplicates
107;; must be the last order in the orders list
108(define (dups x y)
109  0)
110
111;;;; snode ADT (hidden)
112
113(define-record-type snode
114  (make-snode item next)
115  snode?
116  (item snode-item)
117  (next snode-next))
118
119;;; constructor
120(define (snode item height)
121  (make-snode item (make-vector height '())))
122
123;; items of the first and last snode
124(define gstart (gensym 'start))
125(define gfinish (gensym 'finish))
126
127(define (snode-finish? node)
128  (eq? (snode-item node) gfinish))
129
130(define (snode-start? node)
131  (eq? (snode-item node) gstart))
132
133(define snode-next-ref
134  (getter-with-setter
135    (lambda (node k)
136      (vector-ref (snode-next node) k))
137    (lambda (node k new)
138      (vector-set! (snode-next node) k new))))
139
140(define-record-printer (snode node out)
141  (format out "~S#~S"
142          (snode-item node) (snode-height node)))
143
144(define (snode-height node)
145  (vector-length (snode-next node)))
146
147(define-record-type skiplist
148  (make-skiplist width max-height item? orders height count start cursor found level finish)
149  skiplist?
150  (width sl-width)
151  (max-height sl-max-height)
152  (item? sl-item?)
153  (orders sl-orders)
154  ;; setters not exported, cursor not exported
155  (height sl-height sl-height-set!)
156  (count sl-count sl-count-set!)
157  (start sl-start (setter sl-start))
158  (cursor sl-cursor (setter sl-cursor)) ; vector of nodes
159  (found sl-found sl-found-set!)
160  (level sl-search-level sl-search-level-set!)
161  (finish sl-finish (setter sl-finish)))
162
163(define (repeat-string str k) ; internal
164  (let loop ((k k) (result ""))
165    (if (zero? k)
166      result
167      (loop (fx- k 1) (string-append str result)))))
168
169(define-record-printer (skiplist sls out)
170  (format out "#,(skiplist[dups: ~s width: ~s height: ~s count: ~s]"
171          (sl-dups? sls)
172          (sl-width sls)
173          (sl-height sls)
174          (sl-count sls))
175  (if (sl-null? sls)
176    (display ")" out)
177    ;(format out " ~s ... ~s)" (sl-min sls) (sl-max sls))))
178    (let ((smin (sl-min sls)) (smax (sl-max sls)))
179      (format out "~? ...~?)~%"
180              (repeat-string " ~s" (length smin)) smin
181              (repeat-string " ~s" (length smax)) smax))))
182
183;; constructor
184(define skiplist
185  (case-lambda
186    ((width max-height item? order . orders)
187     (let* ((finish (snode gfinish max-height))
188            (start (make-snode gstart (make-vector max-height finish))))
189       (make-skiplist width
190                      max-height
191                      item?
192                      (cons order orders)
193                      1 ; height
194                      0 ; count
195                      start
196                      (vector start) ; cursor
197                      '() ; found
198                      0 ; level
199                      finish)))
200    ((max-height item? order . orders)
201     (apply skiplist 2 max-height item? order orders))
202    ((item? order . orders)
203     (apply skiplist 2 10 item? order orders))))
204
205
206(define (sl-dups? sls)
207  ;; dups as last item in the orders list
208  (let ((dups? (memq dups (sl-orders sls))))
209    (and dups? (null? (cdr dups?)))))
210
211(define (sl-null? sls)
212  (zero? (sl-count sls)))
213
214(define (sl-found? sls item)
215  (member item (sl-found sls)))
216
217;; combine orders
218(define (sl-compare sls)
219  (let loop ((orders (sl-orders sls)))
220    (unless (null? orders)
221      (let ((cmp (car orders)) (rest (cdr orders)))
222        (if (null? rest)
223          cmp
224          (lambda (x y)
225            (if (zero? (cmp x y))
226              ((loop rest) x y)
227              (cmp x y))))))))
228
229;; compare items
230(define (sl-less? sls item0 item1)
231  (cond
232    ((eq? item0 gstart) #t)
233    ((eq? item0 gfinish) #f)
234    ((eq? item1 gstart) #f)
235    ((eq? item1 gfinish) #t)
236    (else
237      (negative?
238        ((sl-compare sls) item0 item1)))))
239
240(define (sl-equal? sls item0 item1)
241  (and (not (sl-less? sls item0 item1))
242       (not (sl-less? sls item1 item0))))
243
244(define (cursor-less? sls k item) ; internal
245  (sl-less? sls (snode-item (cursor-next sls k)) item))
246
247(define (cursor-equal? sls k item) ; internal
248  (sl-equal? sls (snode-item (cursor-next sls k)) item))
249
250;; all operations should happen at the cursor, where it is moved in such
251;; a way, that is less than a node but points to a node which is not
252
253(define cursor-ref ; internal
254  (getter-with-setter
255    (lambda (sls k)
256      (vector-ref (sl-cursor sls) k))
257    (lambda (sls k node)
258      (vector-set! (sl-cursor sls) k node))))
259
260(define cursor-next ; internal
261  (getter-with-setter
262    (lambda (sls k)
263      (snode-next-ref (cursor-ref sls k) k))
264    (lambda (sls k new)
265      (set! (snode-next-ref (cursor-ref sls k) k) new))))
266
267(define sl-start-next
268  (getter-with-setter
269    (lambda (sls k)
270      (snode-next-ref (sl-start sls) k))
271    (lambda (sls k node)
272      (set! (snode-next-ref (sl-start sls) k) node))))
273
274;; cursor movements
275(define (cursor-forth! sls k) ; internal
276  (set! (cursor-ref sls k)
277        (cursor-next sls k)))
278
279(define (cursor-moveto! sls k item) ; internal
280  (do-while (cursor-less? sls k item)
281            (cursor-forth! sls k)))
282
283(define (cursor-start! sls k) ; internal
284  (set! (cursor-ref sls k)
285        (sl-start-next sls k)))
286
287;;; this is where the work gets done!
288;;; it's only needed in sl-max, but a pattern for sl-search!
289;(define (cursor-prepare! sls item)
290;  (let* ((height (sl-height sls)) (top (fx- height 1)))
291;    ;; save cursors at every level
292;    (do ((k top (fx- k 1)))
293;      ((negative? k))
294;      (if (fx= k top)
295;        ;;; restart cursor at highest level only if cursor not less item
296;        (if (not (cursor-less? sls k item))
297;          (set! (cursor-ref sls k) (sl-start sls)))
298;        ;; start at every lower cursor level with the result of the level above
299;        (set! (cursor-ref sls k) (cursor-ref sls (fx+ k 1))))
300;      ;; advance cursor horizontally
301;      (cursor-moveto! sls k item))))
302
303;; the same as cursor-prepare!, but stops earlier, if item found
304;; and collects found items
305(define (sl-search! sls item)
306  (call-with-current-continuation
307    (lambda (out)
308      (let ((top (fx- (sl-height sls) 1)))
309        ;; save cursors at every level
310        (do ((k top (fx- k 1)))
311          ((negative? k))
312          (if (fx= k top)
313            ;;; restart cursor at highest level only if cursor not less item
314            (if (not (cursor-less? sls k item))
315              (set! (cursor-ref sls k) (sl-start sls)))
316            ;; start at every lower cursor level with the result of the level above
317            (set! (cursor-ref sls k) (cursor-ref sls (fx+ k 1))))
318          ;; advance cursor horizontally
319          (cursor-moveto! sls k item)
320          (if (cursor-equal? sls k item) ; item found
321            (begin
322              (sl-search-level-set! sls k)
323              ;; collect found items
324              (let loop ((node (cursor-next sls k)) (found '()))
325                (if (not (sl-equal? sls (snode-item node) item))
326                  (sl-found-set! sls (reverse found))
327                  (loop (snode-next-ref node k)
328                        (cons (snode-item node) found))))
329              (out (void)))
330            (begin
331              (sl-found-set! sls '())
332              (sl-search-level-set! sls k))))))))
333
334(define (sl-search-continue! sls item)
335  ;; save cursors at every level below search level
336  (do ((k (fx- (sl-search-level sls) 1) (fx- k 1)))
337    ((negative? k))
338      ;; restart cursor at every lower cursor level with the result of the level above
339    (set! (cursor-ref sls k) (cursor-ref sls (fx+ k 1)))
340    ;; advance cursor horizontally
341    (cursor-moveto! sls k item)))
342
343(define (choose-height width) ; internal
344  (let loop ((choice (pseudo-random-integer width)) (k 1))
345    (if (fx>= choice 1)
346      k
347      (loop (pseudo-random-integer width) (fx+ k 1)))))
348
349(define (sl-insert! sls item . items)
350  (let ((height (fxmin (sl-max-height sls)
351                       (choose-height (sl-width sls)))))
352    ;; restructure
353    (when (> height (sl-height sls))
354      ;(set! (sl-finish sls) (snode gfinish height))
355      ;(set! (sl-start sls)
356      ;      (make-snode gstart
357      ;                  (vector-resize (snode-next (sl-start sls))
358      ;                                 height
359      ;                                 (sl-finish sls))))
360      (set! (sl-cursor sls)
361            (vector-resize (sl-cursor sls)
362                           height
363                           (sl-start sls)))
364      (sl-search-level-set! sls height)
365      (sl-height-set! sls height))
366    ;; insert
367    (if (sl-dups? sls)
368      (begin
369        ;; prepare upper part of cursor for insertion
370        (sl-search! sls item) ; ok
371        (let* (
372          ;; the new node should have the same height as the
373          ;; found one so removing all is fast
374          (height (if (null? (sl-found sls))
375                    height
376                    (snode-height
377                      (cursor-next sls (sl-search-level sls)))))
378          (new (snode item height))
379          )
380          ;; prepare lower part of cursor for insertion
381          (sl-search-continue! sls item)
382          (sl-count-set! sls (fx+ (sl-count sls) 1))
383          (sl-found-set! sls (cons item (sl-found sls)))
384          (do ((k 0 (fx+ k 1)))
385            ((fx= k height))
386            (set! (snode-next-ref new k)
387                  (cursor-next sls k))
388            (set! (cursor-next sls k) new))))
389      (begin
390        ;; prepare upper part of cursor
391        (sl-search! sls item)
392        (when (null? (sl-found sls))
393          ;; prepare lower part of cursor
394          (sl-search-continue! sls item)
395          (let ((new (snode item height)))
396            (sl-count-set! sls (fx+ (sl-count sls) 1))
397            (do ((k 0 (fx+ k 1)))
398              ((fx= k height))
399              (set! (snode-next-ref new k)
400                    (cursor-next sls k))
401              (set! (cursor-next sls k) new)))))))
402  ;; insert additional items, if there are any
403  (do ((items items (cdr items)))
404    ((null? items))
405    (sl-insert! sls (car items))))
406
407(define (sl-remove! sls item . items)
408  ;; remove one item if found
409  (sl-search! sls item)
410  (if (member item (sl-found sls))
411    (unless (null? (sl-found sls))
412      (let ((level (sl-search-level sls)))
413        ;; advance horizontally until item found
414        (do-while
415          (not (equal? item
416                       (snode-item (cursor-next sls level))))
417          (cursor-forth! sls level))
418        (sl-search-continue! sls item)
419        (when (cursor-equal? sls level item)
420          (set! (cursor-next sls level)
421                (snode-next-ref (cursor-next sls level) level))
422          (sl-count-set! sls (fx- (sl-count sls) 1))
423          (sl-found-set! sls (cdr (sl-found sls)))
424          (do ((k 0 (fx+ k 1)))
425            ((fx= k level))
426            (when (cursor-equal? sls k item)
427              (set! (cursor-next sls k)
428                    (snode-next-ref (cursor-next sls k) k))))))))
429  ;; remove other items, if any
430  (do ((items items (cdr items)))
431    ((null? items))
432    (sl-remove! sls (car items))))
433
434(define (sl-for-each proc sls)
435  (do ((node (snode-next-ref (sl-start sls) 0)
436             (snode-next-ref node 0)))
437    ((snode-finish? node)) ; way out
438    (display "XXXX") (display (snode-item node))
439    (proc (snode-item node))))
440
441(define (sl-clear! sls)
442  (sl-height-set! sls 1)
443  (set! (sl-finish sls) (snode gfinish 1))
444  (set! (sl-start sls) (snode gstart 1))
445  (set! (sl-start-next sls 0) (sl-finish sls))
446  (set! (sl-cursor sls) (make-vector 1 (sl-start sls)))
447  (sl-count-set! sls 0))
448
449(define (sl-map proc sls . target-structure)
450  (let (
451    (result
452      (cond
453        ;; old width and orders
454        ((null? target-structure)
455         (apply skiplist (sl-width sls) (sl-item? sls) (sl-orders sls)))
456        ;; old width, new item? and orders
457        (((list-of? procedure?) target-structure)
458         (apply skiplist (sl-width sls) target-structure))
459        ;; new width, old item? and orders
460        ((null? (cdr target-structure))
461         (apply skiplist (car target-structure) (sl-item? sls) (sl-orders sls)))
462        ;; new width, new item? and orders
463        (else
464          (apply skiplist target-structure))))
465    )
466    (do ((node (snode-next-ref (sl-start sls) 0)
467               (snode-next-ref node 0)))
468      ((snode-finish? node)) ; way out
469      (sl-insert! result (proc (snode-item node))))
470    result))
471
472(define (sl-restructure sls width max-height)
473  ;(sl-map sls identity width))
474  (let ((result (apply skiplist
475                       width
476                       max-height
477                       (sl-item? sls)
478                       (sl-orders sls))))
479    (do ((node (snode-next-ref (sl-start sls) 0) (snode-next-ref node 0)))
480      ((snode-finish? node))
481      (sl-insert! result (snode-item node)))
482    result))
483
484(define (sl-reorder sls order . orders)
485  ;(apply sl-map sls identity order orders))
486  (let ((result (apply skiplist
487                       (sl-width sls)
488                       (sl-max-height sls)
489                       (sl-item?  sls)
490                       order orders)))
491    (do ((node (snode-next-ref (sl-start sls) 0) (snode-next-ref node 0)))
492      ((snode-finish? node))
493      (sl-insert! result (snode-item node)))
494    result))
495
496(define (sl-filter ok? sls)
497  (let ((result (apply skiplist
498                       (sl-width sls)
499                       (sl-max-height sls)
500                       (sl-item?  sls)
501                       (sl-orders sls))))
502    (do ((node (snode-next-ref (sl-start sls) 0)
503               (snode-next-ref node 0)))
504      ((snode-finish? node)) ; way out
505      (let ((item (snode-item node)))
506        (if (ok? item) (sl-insert! result item))))
507    result))
508
509(define (sl-min sls)
510  (if (sl-null? sls)
511    '()
512    (begin
513      (cursor-start! sls 0)
514      ;(snode-item (cursor-ref sls 0)))
515      (sl-search! sls (snode-item (cursor-ref sls 0)))
516      (sl-found sls))))
517  ;(let ((item (snode-item (cursor-ref sls 0))))
518  ;  (if (sl-dups? sls)
519  ;    (begin
520  ;      (sl-search! sls item)
521  ;      (sl-found sls))
522  ;    item)))
523
524(define (sl-max sls)
525  ;; sl-search! won't work since gfinish is of wrong type;
526  ;; moreover it stores the next item in found, wheras max is the
527  ;; present item at level 0 after moveto!
528  (if (sl-null? sls)
529    '()
530    (begin
531      (let ((top (fx- (sl-height sls) 1)))
532        ;; save cursors at every level
533        (do ((k top (fx- k 1)))
534          ((negative? k))
535          ;; at highest start where you are, it's always less gfinish
536          (if (fx< k top)
537            ;; start at every lower cursor level with the result of the level above
538            (set! (cursor-ref sls k) (cursor-ref sls (fx+ k 1))))
539          ;; advance cursor horizontally
540          (cursor-moveto! sls k gfinish)))
541      ;(snode-item (cursor-ref sls 0)))
542      (sl-search! sls (snode-item (cursor-ref sls 0)))
543      (sl-found sls))))
544
545(define (skiplist->list sls . level)
546  (let ((k (optional level 0)))
547    (cursor-start! sls k)
548    (let loop ((node (cursor-ref sls k)) (result '()))
549      (if (snode-finish? node)
550        (reverse result)
551        (loop (snode-next-ref node k) (cons (snode-item node) result))))))
552
553(define skiplists
554  (let ((als '(
555    (skiplists
556      procedure:
557      (skiplists)
558      (skiplists sym)
559      "documentation procedure."
560      "The first call shows the list of exported symbols,"
561      "the second documentation of symbol sym.")
562    (skiplist
563      procedure:
564      (skiplist width max-height item? order . orders)
565      (skiplist max-height item? order . orders)
566      (skiplist item? order . orders)
567      "constructors:"
568      "width is the jump width,"
569      "max-height the maximum allowed length of pointers of an item,"
570      "item? checks items")
571    (skiplist?
572      procedure:
573      (skiplist? xpr)
574      "type predicate.")
575    (skiplist->list
576      procedure:
577      (skiplist->list sls)
578      (skiplist->list sls level)
579      "the list of items stored in each level")
580    (sl-null?
581      procedure:
582      (sl-null? sls)
583      "is skiplist empty?")
584    (sl-dups?
585      procedure:
586      (sl-dups? sls)
587      "are duplicates allowed?")
588    (sl-item?
589      procedure:
590      (sl-item? sls)
591      "item type predicate")
592    (dups
593      procedure:
594      (dups x y)
595      "trivial numerical comparison operator to be used"
596      "as last order to allow duplicates")
597    (sl-compare
598      procedure:
599      (sl-compare sls)
600      "combined comparison function")
601    (sl-count
602      procedure:
603      (sl-count sls)
604      "number of items stored in skiplist")
605    (sl-found
606      procedure:
607      (sl-found sls)
608      "list of found items, to be called after search!")
609    (sl-found?
610      procedure:
611      (sl-found? sls item)
612      "is item found?")
613    (sl-height
614      procedure:
615      (sl-height sls)
616      "actual maximal height of nodes (can be changed)")
617    (sl-max-height
618      procedure:
619      (sl-max-height sls)
620      "absolute maximum heigth of nodes in skiplist (not changeble)")
621    (sl-max
622      procedure:
623      (sl-max sls)
624      "biggest item stored in skiplist")
625    (sl-min
626      procedure:
627      (sl-min sls)
628      "smallest item stored in skiplist")
629    (sl-orders
630      procedure:
631      (sl-orders sls)
632      "list of orders defined in the constructor")
633    (sl-search-level
634      procedure:
635      (sl-search-level sls)
636      "down to which level a previous search descended?")
637    (sl-width
638      procedure:
639      (sl-width sls)
640      "width skipped on average at each search level supplied by constructor")
641    (sl-map
642      procedure:
643      (sl-map fn sls)
644      (sl-map fn sls order . orders)
645      (sl-map fn sls width)
646      (sl-map fn sls width order . orders)
647      "depending on the mapping function, different order"
648      "procedures might be necessary")
649    (sl-for-each
650      procedure:
651      (sl-for-each proc sls)
652      "apply proc to each item in skiplist")
653    (sl-filter
654      procedure:
655      (sl-filter ok? sls)
656      "filtering")
657    (sl-reorder
658      procedure:
659      (sl-reorder sls order . orders)
660      "changing orders")
661    (sl-restructure
662      procedure:
663      (sl-restructure sls width max-height)
664      "changing width")
665    (sl-insert!
666      procedure:
667      (sl-insert! sls item . items)
668      "insert new items into skiplist")
669    (sl-remove!
670      procedure:
671      (sl-remove! sls item . items)
672      "remove items from skiplist")
673    (sl-search!
674      procedure:
675      (sl-search! sls item)
676      "searching for an item changes internal cursor transparently")
677    (sl-clear!
678      procedure:
679      (sl-clear! sls)
680      "reset skiplist")
681    )))
682    (case-lambda
683      (()
684       (map car als))
685      ((sym)
686       (let ((pair (assq sym als)))
687         (if pair
688           (for-each print (cdr pair))
689           (error "Not in list"
690                  sym
691                  (map car als))))))))
692
693) ; module %skiplists
694
695(module skiplists
696  (skiplist skiplist? skiplist->list sl-null?
697            sl-item? sl-found?
698            sl-dups? sl-insert! sl-remove!
699            sl-clear! sl-search! sl-orders
700            sl-compare sl-width sl-height
701            sl-found sl-filter sl-map
702            sl-for-each sl-reorder sl-restructure
703            sl-count sl-search-level sl-min
704            sl-max sl-max-height dups) 
705
706
707(import scheme
708        (only (chicken base)
709              case-lambda error cut fixnum? list-of? constantly)
710        (only (chicken fixnum) fx+ fx- fx>= fx> fx< fx<= fx=)
711        (only (chicken module) reexport)
712        (prefix (except %skiplists dups skiplists) %))
713
714(reexport (only %skiplists dups skiplists))
715
716(define-syntax << ; internal (to avoid importing checks)
717  (syntax-rules ()
718    ((_ var)
719     var)
720    ((_ var ok?)
721     (if (ok? var)
722       var
723       (error "test failed" ok?)))
724    ((_ var ok? ok1? ...)
725     (if (ok? var)
726       (<< var ok1? ...)
727       (error "test failed" ok?)))
728    ))
729
730;;; constructor
731(define skiplist
732  (case-lambda
733    ((width max-height item? order . orders)
734     (apply %skiplist
735            (<< width fixnum? (cut fx> <> 1))
736            (<< max-height fixnum? (cut fx> <> 1))
737            (<< item? procedure?)
738            (<< order procedure?)
739            (<< orders (list-of? procedure?))))
740    ((max-height item? order . orders)
741     (apply skiplist 2 max-height item? order orders))
742    ((item? order . orders)
743     (apply skiplist 2 10 item? order orders))))
744
745;;; predicates
746(define skiplist? %skiplist?)
747
748;; the list of items stored in each level
749(define skiplist->list
750  (case-lambda
751    ((sls)
752     (%skiplist->list (<< sls %skiplist?)))
753    ((sls level)
754     (%skiplist->list (<< sls %skiplist?)
755                (<< level fixnum?
756                          (cut fx<= 0 <>)
757                          (cut fx< <> (%sl-height sls)))))
758    ))
759
760;; is skiplist empty?
761(define (sl-null? sls)
762  (%sl-null? (<< sls %skiplist?)))
763
764;; are duplicates allowed?
765(define (sl-dups? sls)
766  (%sl-dups? (<< sls %skiplist?)))
767
768;; item type predicate
769(define (sl-item? sls)
770  (%sl-item? (<< sls %skiplist?)))
771
772;; item found?
773(define (sl-found? sls item)
774  (%sl-found? (<< sls %skiplist?)
775              (<< item (%sl-item? sls))))
776
777;;; functions
778
779;; list of found items, to be called after search!
780(define (sl-found sls)
781  (%sl-found (<< sls %skiplist?)))
782
783;; smallest item stored in skiplist
784(define (sl-min sls)
785  (%sl-min (<< sls %skiplist?)))
786
787;; biggest item stored in skiplist
788(define (sl-max sls)
789  (%sl-max (<< sls %skiplist?)))
790
791;; actual height of nodes (can be changed)
792(define (sl-height sls)
793  (%sl-height (<< sls %skiplist?)))
794
795;; absolute maximum heigth of nodes in skiplist (not changeble)
796(define (sl-max-height sls)
797  (%sl-max-height (<< sls %skiplist?)))
798
799;; width skipped on average at each search level supplied by constructor
800(define (sl-width sls)
801  (%sl-width (<< sls %skiplist?)))
802
803;; number of items stored in skiplist
804(define (sl-count sls)
805  (%sl-count (<< sls %skiplist?)))
806
807;; list of orders defined in the constructor
808(define (sl-orders sls)
809  (%sl-orders (<< sls %skiplist?)))
810
811;; combined comparison function
812(define (sl-compare sls)
813  (%sl-compare (<< sls %skiplist?)))
814 
815;; down to which level a previous search descended?
816(define (sl-search-level sls)
817  (%sl-search-level (<< sls %skiplist?)))
818
819;; filtering
820(define (sl-filter ok? sls)
821  (%sl-filter (<< ok? procedure?)
822              (<< sls %skiplist?)))
823
824;; mapping: depending on the mapping function, different order
825;; procedures might be necessary
826(define sl-map
827  (case-lambda
828    ((fn sls)
829     (%sl-map (<< fn procedure?)
830              (<< sls %skiplist?)))
831    ((fn sls width)
832     (%sl-map (<< fn procedure?)
833              (<< sls %skiplist?)
834              (<< width fixnum? (cut fx> <> 1))))
835    ((fn sls order . orders)
836     (apply %sl-map
837            (<< fn procedure?)
838            (<< sls %skiplist?)
839            (<< order procedure?)
840            (<< orders (list-of? procedure?))))
841    ((fn sls width order . orders)
842     (apply %sl-map
843            (<< fn procedure?)
844            (<< sls %skiplist?)
845            (<< width fixnum? (cut fx> <> 1))
846            (<< order procedure?)
847            (<< orders (list-of? procedure?))))
848   ))
849
850;; apply proc to each item in skiplist
851(define (sl-for-each proc sls)
852  (%sl-for-each (<< proc procedure?)
853                (<< sls %skiplist?)))
854
855
856;; changing orders
857(define (sl-reorder sls order . orders)
858  (apply %sl-reorder
859         (<< sls %skiplist?)
860         (<< order procedure?)
861         (<< orders (list-of? procedure?))))
862
863;; changing width
864(define (sl-restructure sls width max-height)
865  (%sl-restructure (<< sls %skiplist?)
866                   (<< width fixnum? (cut fx> <> 1))
867                   (<< max-height fixnum? (cut fx> <> 1))))
868
869;;; commands
870
871;; searching for an item changes cursor transparently
872(define (sl-search! sls item)
873  (%sl-search! (<< sls %skiplist?)
874               (<< item (%sl-item? sls))))
875
876;; insert items into skiplist
877(define (sl-insert! sls item . items)
878  (apply %sl-insert!
879         (<< sls %skiplist?)
880         (<< item (%sl-item? sls))
881         (<< items (list-of? (%sl-item? sls)))))
882
883;; remove items from skiplist
884(define (sl-remove! sls item . items)
885  (apply %sl-remove!
886         (<< sls %skiplist?)
887         (<< item (%sl-item? sls))
888         (<< items (list-of? (%sl-item? sls)))))
889
890;; reset skiplist
891(define (sl-clear! sls)
892  (%sl-clear! (<< sls %skiplist?)))
893
894) ; module skiplists
Note: See TracBrowser for help on using the repository browser.