Changeset 27161 in project


Ignore:
Timestamp:
08/02/12 17:50:51 (7 years ago)
Author:
juergen
Message:

version 0.6 with restructured code (additional module

Location:
release/4/skiplists
Files:
2 edited
3 copied

Legend:

Unmodified
Added
Removed
  • release/4/skiplists/tags/0.6/skiplists.scm

    r26761 r27161  
    3333;         ju (at) jugilo (dot) de
    3434;
    35 ; Last update: May 21, 2012
     35; Last update: Aug 2, 2012
    3636;
    3737;Rationale
     
    7474;below n.
    7575;
    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)
     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)
    8585
    8686(import scheme records
    87   (only contracts doclist doclist->dispatcher contract define-with-contract)
    8887  (only chicken
    8988    assert when unless keyword? optional
    90     getter-with-setter print get-output-string open-output-string)
     89    getter-with-setter print); get-output-string open-output-string)
    9190  (only data-structures list-of?)
    9291  (only extras random))
    93 
    94 ;; initialize documentation
    95 (doclist '())
    9692
    9793;;;; skipnode ADT (hidden)
     
    149145    '(orders gap links count cursor start)))
    150146
     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
    151357(define-with-contract (skiplist? xpr)
    152358  "type predicate"
    153359  (%skiplist? xpr))
    154360
    155 (define %skiplist?  (record-predicate skip-type))
    156 
    157 (define skip-maker
    158   (record-constructor skip-type))
    159 
    160361(define-with-contract (skip-orders skp)
    161362  "list of numerical comparison operators"
     
    164365  (%skip-orders skp))
    165366
    166 (define %skip-orders (record-accessor skip-type 'orders))
    167 
    168367(define-with-contract (skip-gap skp)
    169368  "gap of skiplist"
     
    172371  (%skip-gap skp))
    173372
    174 (define %skip-gap (record-accessor skip-type 'gap))
    175  
    176 
    177373(define-with-contract (skip-count skp)
    178374  "number of nodes stored in skiplist"
     
    181377  (%skip-count skp))
    182378
    183 (define %skip-count
    184   (getter-with-setter (record-accessor skip-type 'count)
    185                       (record-modifier skip-type 'count)))
    186 
    187379(define-with-contract (skip-links skp)
    188380  "maximal number of occupied links"
     
    190382  (range (integer? result) (>= (%skip-max-links skp) result 1))
    191383  (%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)))
    202384
    203385(define-with-contract (make-skiplist max-links . orders)
     
    220402  (apply %make-skiplist-with-gap max-links gap orders))
    221403 
    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 
    227404(define-with-contract (make-skiplist-from-list lst max-links . orders)
    228405  "construct a skiplist from an ordinary list"
     
    249426  (apply %make-skiplist-with-gap-from-list lst max-links gap orders))
    250427
    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 
    259428(define-with-contract (skip-restructure skp max-links gap)
    260429  "restructure skiplist by changing max-links and gap"
     
    265434         (= (%skip-gap result) gap))
    266435  (%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))
    277436
    278437(define-with-contract (skip-reorder skp . orders)
     
    286445  (apply %skip-reorder skp orders))
    287446
    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 
    299447(define (set-in? lst1 lst2)
    300448  (let loop ((lst lst1))
     
    309457          (procedure? proc))
    310458  (%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)))))
    317459
    318460(define-with-contract (skip-filter skp ok?)
     
    323465  (range (%skiplist? result))
    324466  (%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))
    337467
    338468(define-with-contract (skip-list skp . ks)
     
    346476  (apply %skip-list skp ks))
    347477
    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 
    356478(define-with-contract (skip-max-links skp)
    357479  "maximal number of links"
     
    360482  (%skip-max-links skp))
    361483
    362 (define (%skip-max-links skp)
    363   (skipnode-links (skip-start skp)))
    364 
    365484(define-with-contract (skip-dups? skp)
    366485  "check if duplicates are allowed"
     
    368487  (%skip-dups? skp))
    369488
    370 (define (%skip-dups? skp)
    371   ;; more than one initial comparison operator
    372   (not (null? (cdr (%skip-orders skp)))))
    373 
    374489(define-with-contract (skip-compare skp)
    375490  "combined numerical comparison procedure"
     
    377492  (range (procedure? result))
    378493  (%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))))))))
    390494
    391495(define-with-contract (skip-search! skp item)
     
    396500  (%skip-search! skp item))
    397501 
    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 
    419502(define-with-contract (skip-found? skp item)
    420503  "check, if last skip-search! was successfull"
     
    422505  (range (boolean? result))
    423506  (%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)))
    441507
    442508(define-with-contract (skip-insert! skp . items)
     
    450516      (loop (cdr items)))))
    451517
    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 
    462518(define-with-contract (skip-remove! skp . items)
    463519  "remove nodes (one per found item) with items from skiplist"
     
    469525    (loop (cdr items)))))
    470526 
    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 
    477527(define-with-contract (skip-remove-all! skp . items)
    478528  "remove nodes (all per found item) with items from skiplist"
     
    484534    (loop (cdr items)))))
    485535 
    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 
    512536(define-with-contract (dups x y)
    513537  "trivial numerical comparison operator to allow for duplicates"
  • release/4/skiplists/tags/0.6/skiplists.setup

    r26761 r27161  
    33(compile -O2 -s -d1 skiplists.scm -J)
    44(compile -O3 -d0 -s skiplists.import.scm)
     5(compile -O3 -d0 -s %skiplists.import.scm)
    56
    67(install-extension
    78 'skiplists
    8  '("skiplists.so" "skiplists.import.so")
    9  '((version "0.5")))
     9 '("skiplists.so" "%skiplists.import.so" "skiplists.import.so")
     10 '((version "0.6")))
    1011
    1112
  • release/4/skiplists/trunk/skiplists.scm

    r26761 r27161  
    3333;         ju (at) jugilo (dot) de
    3434;
    35 ; Last update: May 21, 2012
     35; Last update: Aug 2, 2012
    3636;
    3737;Rationale
     
    7474;below n.
    7575;
    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)
     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)
    8585
    8686(import scheme records
    87   (only contracts doclist doclist->dispatcher contract define-with-contract)
    8887  (only chicken
    8988    assert when unless keyword? optional
    90     getter-with-setter print get-output-string open-output-string)
     89    getter-with-setter print); get-output-string open-output-string)
    9190  (only data-structures list-of?)
    9291  (only extras random))
    93 
    94 ;; initialize documentation
    95 (doclist '())
    9692
    9793;;;; skipnode ADT (hidden)
     
    149145    '(orders gap links count cursor start)))
    150146
     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
    151357(define-with-contract (skiplist? xpr)
    152358  "type predicate"
    153359  (%skiplist? xpr))
    154360
    155 (define %skiplist?  (record-predicate skip-type))
    156 
    157 (define skip-maker
    158   (record-constructor skip-type))
    159 
    160361(define-with-contract (skip-orders skp)
    161362  "list of numerical comparison operators"
     
    164365  (%skip-orders skp))
    165366
    166 (define %skip-orders (record-accessor skip-type 'orders))
    167 
    168367(define-with-contract (skip-gap skp)
    169368  "gap of skiplist"
     
    172371  (%skip-gap skp))
    173372
    174 (define %skip-gap (record-accessor skip-type 'gap))
    175  
    176 
    177373(define-with-contract (skip-count skp)
    178374  "number of nodes stored in skiplist"
     
    181377  (%skip-count skp))
    182378
    183 (define %skip-count
    184   (getter-with-setter (record-accessor skip-type 'count)
    185                       (record-modifier skip-type 'count)))
    186 
    187379(define-with-contract (skip-links skp)
    188380  "maximal number of occupied links"
     
    190382  (range (integer? result) (>= (%skip-max-links skp) result 1))
    191383  (%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)))
    202384
    203385(define-with-contract (make-skiplist max-links . orders)
     
    220402  (apply %make-skiplist-with-gap max-links gap orders))
    221403 
    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 
    227404(define-with-contract (make-skiplist-from-list lst max-links . orders)
    228405  "construct a skiplist from an ordinary list"
     
    249426  (apply %make-skiplist-with-gap-from-list lst max-links gap orders))
    250427
    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 
    259428(define-with-contract (skip-restructure skp max-links gap)
    260429  "restructure skiplist by changing max-links and gap"
     
    265434         (= (%skip-gap result) gap))
    266435  (%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))
    277436
    278437(define-with-contract (skip-reorder skp . orders)
     
    286445  (apply %skip-reorder skp orders))
    287446
    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 
    299447(define (set-in? lst1 lst2)
    300448  (let loop ((lst lst1))
     
    309457          (procedure? proc))
    310458  (%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)))))
    317459
    318460(define-with-contract (skip-filter skp ok?)
     
    323465  (range (%skiplist? result))
    324466  (%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))
    337467
    338468(define-with-contract (skip-list skp . ks)
     
    346476  (apply %skip-list skp ks))
    347477
    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 
    356478(define-with-contract (skip-max-links skp)
    357479  "maximal number of links"
     
    360482  (%skip-max-links skp))
    361483
    362 (define (%skip-max-links skp)
    363   (skipnode-links (skip-start skp)))
    364 
    365484(define-with-contract (skip-dups? skp)
    366485  "check if duplicates are allowed"
     
    368487  (%skip-dups? skp))
    369488
    370 (define (%skip-dups? skp)
    371   ;; more than one initial comparison operator
    372   (not (null? (cdr (%skip-orders skp)))))
    373 
    374489(define-with-contract (skip-compare skp)
    375490  "combined numerical comparison procedure"
     
    377492  (range (procedure? result))
    378493  (%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))))))))
    390494
    391495(define-with-contract (skip-search! skp item)
     
    396500  (%skip-search! skp item))
    397501 
    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 
    419502(define-with-contract (skip-found? skp item)
    420503  "check, if last skip-search! was successfull"
     
    422505  (range (boolean? result))
    423506  (%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)))
    441507
    442508(define-with-contract (skip-insert! skp . items)
     
    450516      (loop (cdr items)))))
    451517
    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 
    462518(define-with-contract (skip-remove! skp . items)
    463519  "remove nodes (one per found item) with items from skiplist"
     
    469525    (loop (cdr items)))))
    470526 
    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 
    477527(define-with-contract (skip-remove-all! skp . items)
    478528  "remove nodes (all per found item) with items from skiplist"
     
    484534    (loop (cdr items)))))
    485535 
    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 
    512536(define-with-contract (dups x y)
    513537  "trivial numerical comparison operator to allow for duplicates"
  • release/4/skiplists/trunk/skiplists.setup

    r26761 r27161  
    33(compile -O2 -s -d1 skiplists.scm -J)
    44(compile -O3 -d0 -s skiplists.import.scm)
     5(compile -O3 -d0 -s %skiplists.import.scm)
    56
    67(install-extension
    78 'skiplists
    8  '("skiplists.so" "skiplists.import.so")
    9  '((version "0.5")))
     9 '("skiplists.so" "%skiplists.import.so" "skiplists.import.so")
     10 '((version "0.6")))
    1011
    1112
Note: See TracChangeset for help on using the changeset viewer.