Changeset 27161 in project
- Timestamp:
- 08/02/12 17:50:51 (7 years ago)
- Location:
- release/4/skiplists
- Files:
-
- 2 edited
- 3 copied
Legend:
- Unmodified
- Added
- Removed
-
release/4/skiplists/tags/0.6/skiplists.scm
r26761 r27161 33 33 ; ju (at) jugilo (dot) de 34 34 ; 35 ; Last update: May 21, 201235 ; Last update: Aug 2, 2012 36 36 ; 37 37 ;Rationale … … 74 74 ;below n. 75 75 ; 76 (require 'records 'contracts)77 78 (module skiplists79 (skiplist s skiplist? make-skiplist make-skiplist-with-gap skip-compare80 81 82 83 84 76 (require-library records contracts) 77 78 (module %skiplists 79 (skiplist? make-skiplist make-skiplist-with-gap skip-compare 80 make-skiplist-from-list make-skiplist-with-gap-from-list 81 skip-search! skip-insert! skip-remove! skip-list skip-gap skip-count 82 skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups 83 skip-restructure skip-for-each skip-orders skip-reorder 84 skip-filter) 85 85 86 86 (import scheme records 87 (only contracts doclist doclist->dispatcher contract define-with-contract)88 87 (only chicken 89 88 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) 91 90 (only data-structures list-of?) 92 91 (only extras random)) 93 94 ;; initialize documentation95 (doclist '())96 92 97 93 ;;;; skipnode ADT (hidden) … … 149 145 '(orders gap links count cursor start))) 150 146 147 (define skiplist? (record-predicate skip-type)) 148 149 (define skip-maker 150 (record-constructor skip-type)) 151 152 (define skip-orders (record-accessor skip-type 'orders)) 153 154 (define skip-gap (record-accessor skip-type 'gap)) 155 156 (define skip-count 157 (getter-with-setter (record-accessor skip-type 'count) 158 (record-modifier skip-type 'count))) 159 160 (define skip-links 161 (getter-with-setter (record-accessor skip-type 'links) 162 (record-modifier skip-type 'links))) 163 164 (define (skip-cursor skp) 165 (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp))) 166 167 (define (skip-start skp) 168 (make-skipnode start: ((record-accessor skip-type 'start) skp))) 169 170 (define (make-skiplist max-links . orders) 171 (apply make-skiplist-with-gap max-links 2 orders)) 172 173 (define (make-skiplist-with-gap max-links gap . orders) 174 (skip-maker orders gap 1 0 175 (make-vector max-links '()) 176 (make-vector max-links '()))) 177 178 (define (make-skiplist-from-list lst max-links . orders) 179 (apply make-skiplist-with-gap-from-list lst max-links 2 orders)) 180 181 (define (make-skiplist-with-gap-from-list lst max-links gap . orders) 182 (let ((skp (apply make-skiplist-with-gap max-links gap orders))) 183 (let loop ((lst lst)) 184 (unless (null? lst) 185 (skip-insert! skp (car lst)) 186 (loop (cdr lst)))) 187 skp)) 188 189 (define (skip-restructure skp max-links gap) 190 (let ( 191 (result (apply make-skiplist-with-gap max-links gap (skip-orders skp))) 192 ) 193 (let loop ((node (skipnode-next (skip-start skp) 0))) 194 (unless (null? node) 195 (skip-insert! result (skipnode-item node)) 196 (loop (skipnode-next node 0)))) 197 result)) 198 199 (define (skip-reorder skp . orders) 200 (let ((result (apply make-skiplist-with-gap 201 (skip-max-links skp) 202 (skip-gap skp) 203 orders))) 204 (let loop ((node (skipnode-next (skip-start skp) 0))) 205 (unless (null? node) 206 (skip-insert! result (skipnode-item node)) 207 (loop (skipnode-next node 0)))) 208 result)) 209 210 (define (skip-for-each skp proc) 211 (let loop ((node (skipnode-next (skip-start skp) 0))) 212 (unless (null? node) 213 (proc (skipnode-item node)) 214 (loop (skipnode-next node 0))))) 215 216 (define (skip-filter skp ok?) 217 (let ((result (apply make-skiplist-with-gap 218 (skip-max-links skp) 219 (skip-gap skp) 220 (skip-orders skp)))) 221 (let loop ((node (skipnode-next (skip-start skp) 0))) 222 (unless (null? node) 223 (let ((item (skipnode-item node))) 224 (if (ok? item) (skip-insert! result item))) 225 (loop (skipnode-next node 0)))) 226 result)) 227 228 (define (skip-list skp . ks) 229 (let ((k ;(if (null? ks) 0 (car ks)))) 230 (optional ks 0))) 231 (let loop ((node (skipnode-next (skip-start skp) k)) (lst '())) 232 (if (null? node) 233 (reverse lst) 234 (loop (skipnode-next node k) (cons (skipnode-item node) lst)))))) 235 236 (define (skip-max-links skp) 237 (skipnode-links (skip-start skp))) 238 239 (define (skip-dups? skp) 240 ;; more than one initial comparison operator 241 (not (null? (cdr (skip-orders skp))))) 242 243 (define (skip-compare skp) 244 (let loop ((orders (skip-orders skp))) 245 (unless (null? orders) 246 (let ((cmp (car orders)) (rest (cdr orders))) 247 (if (null? rest) 248 cmp 249 (lambda (x y) 250 (if (zero? (cmp x y)) 251 ((loop rest) x y) 252 (cmp x y)))))))) 253 254 (define (skip-search! skp item . flags) 255 (let ((lazy? (optional flags #t)) (cursor (skip-cursor skp))) 256 ; the lazy? argument is set to #f in skip-insert! to cope 257 ; with lists which are alreade sorted 258 (let down ( 259 (k (- (skip-links skp) 1)) 260 ;(node (skip-start skp)) 261 (node (if (and lazy? (skip-lazy? skp item)) 262 cursor 263 (skip-start skp))) 264 ) 265 (unless (negative? k) 266 (let forward ((node node)) 267 (let ((next (skipnode-next node k))) 268 (if (skip-in? skp item next) 269 (forward next) 270 (begin 271 (set! (skipnode-next cursor k) node) 272 (down (- k 1) node))))))))) 273 274 (define (skip-found? skp item) 275 (let ((node (skipnode-next (skip-cursor skp) 0))) 276 (and (not (null? node)) 277 (not (null? (skipnode-next node 0))) 278 (zero? ((skip-compare skp) item (skipnode-item (skipnode-next node 0))))))) 279 280 (define (skip-lazy? skp item) 281 (let ((node (skipnode-next (skip-cursor skp) 0))) 282 (and (not (null? node)) 283 (not (keyword? (skipnode-item node))) 284 (positive? ((skip-compare skp) item (skipnode-item node)))))) 285 286 (define (skip-in? skp item node) 287 (and (not (null? node)) 288 (not (keyword? (skipnode-item node))) 289 (> ((skip-compare skp) item (skipnode-item node)) 0))) 290 291 (define (skip-insert! skp item) 292 (skip-search! skp item #f) 293 (unless (and (not (skip-dups? skp)) (skip-found? skp item)) 294 (let ((newlinks (skip-rand skp)) (links (skip-links skp))) 295 (if (> newlinks links) 296 (set! (skip-links skp) newlinks)) 297 (skipnode-insert! (skip-cursor skp) 298 (make-skipnode item (make-vector newlinks '()))) 299 (set! (skip-count skp) (+ (skip-count skp) 1))))) 300 301 (define (skip-remove! skp item) 302 (skip-search! skp item) 303 (when (skip-found? skp item) 304 (skipnode-remove! (skip-cursor skp) (skip-links skp)) 305 (set! (skip-count skp) (- (skip-count skp) 1)))) 306 307 (define (skip-remove-all! skp item) 308 (skip-search! skp item) 309 (let loop ((found (skip-found? skp item))) 310 (when found 311 (skipnode-remove! (skip-cursor skp) (skip-links skp)) 312 (set! (skip-count skp) (- (skip-count skp) 1)) 313 (loop (skip-found? skp item))))) 314 315 ;;; to skip gap nodes at a time in the 2nd level (link index 1), one 316 ;;; out of every gap nodes must have at least 2 links. Iterating we 317 ;;; want one out of every gap^i nodes to have at least i+1 links. 318 (define (skip-rand skp) 319 (let ((max-links (skip-max-links skp))) 320 (if (= max-links 1) 321 1 ; normal list, no randomization 322 (let* ( 323 (gap (skip-gap skp)) 324 (M (expt gap max-links)) 325 (choice (+ (random M) 1)) ; 0<=(random M)<M 326 ) ; 1<=choice<=M 327 (assert (exact? M) "too many links in skip-rand" max-links) 328 (let loop ((links 1) (barrier (quotient M gap))) 329 (if (>= choice barrier) 330 links 331 (loop (+ links 1) (quotient barrier gap)))))))) 332 333 (define (dups x y) 334 0) 335 336 ) ; module %skiplists 337 338 (module skiplists 339 (skiplists skiplist? make-skiplist make-skiplist-with-gap skip-compare 340 make-skiplist-from-list make-skiplist-with-gap-from-list 341 skip-search! skip-insert! skip-remove! skip-list skip-gap skip-count 342 skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups 343 skip-restructure skip-for-each skip-orders skip-reorder 344 skip-filter) 345 346 (import scheme 347 (prefix %skiplists %) 348 (only contracts doclist doclist->dispatcher contract define-with-contract) 349 (only chicken unless get-output-string open-output-string) 350 (only data-structures list-of?)) 351 352 ;; initialize documentation 353 (doclist '()) 354 355 ;;;; skiplist ADT 356 151 357 (define-with-contract (skiplist? xpr) 152 358 "type predicate" 153 359 (%skiplist? xpr)) 154 360 155 (define %skiplist? (record-predicate skip-type))156 157 (define skip-maker158 (record-constructor skip-type))159 160 361 (define-with-contract (skip-orders skp) 161 362 "list of numerical comparison operators" … … 164 365 (%skip-orders skp)) 165 366 166 (define %skip-orders (record-accessor skip-type 'orders))167 168 367 (define-with-contract (skip-gap skp) 169 368 "gap of skiplist" … … 172 371 (%skip-gap skp)) 173 372 174 (define %skip-gap (record-accessor skip-type 'gap))175 176 177 373 (define-with-contract (skip-count skp) 178 374 "number of nodes stored in skiplist" … … 181 377 (%skip-count skp)) 182 378 183 (define %skip-count184 (getter-with-setter (record-accessor skip-type 'count)185 (record-modifier skip-type 'count)))186 187 379 (define-with-contract (skip-links skp) 188 380 "maximal number of occupied links" … … 190 382 (range (integer? result) (>= (%skip-max-links skp) result 1)) 191 383 (%skip-links skp)) 192 193 (define %skip-links194 (getter-with-setter (record-accessor skip-type 'links)195 (record-modifier skip-type 'links)))196 197 (define (skip-cursor skp)198 (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp)))199 200 (define (skip-start skp)201 (make-skipnode start: ((record-accessor skip-type 'start) skp)))202 384 203 385 (define-with-contract (make-skiplist max-links . orders) … … 220 402 (apply %make-skiplist-with-gap max-links gap orders)) 221 403 222 (define (%make-skiplist-with-gap max-links gap . orders)223 (skip-maker orders gap 1 0224 (make-vector max-links '())225 (make-vector max-links '())))226 227 404 (define-with-contract (make-skiplist-from-list lst max-links . orders) 228 405 "construct a skiplist from an ordinary list" … … 249 426 (apply %make-skiplist-with-gap-from-list lst max-links gap orders)) 250 427 251 (define (%make-skiplist-with-gap-from-list lst max-links gap . orders)252 (let ((skp (apply %make-skiplist-with-gap max-links gap orders)))253 (let loop ((lst lst))254 (unless (null? lst)255 (%skip-insert! skp (car lst))256 (loop (cdr lst))))257 skp))258 259 428 (define-with-contract (skip-restructure skp max-links gap) 260 429 "restructure skiplist by changing max-links and gap" … … 265 434 (= (%skip-gap result) gap)) 266 435 (%skip-restructure skp max-links gap)) 267 268 (define (%skip-restructure skp max-links gap)269 (let (270 (result (apply %make-skiplist-with-gap max-links gap (%skip-orders skp)))271 )272 (let loop ((node (skipnode-next (skip-start skp) 0)))273 (unless (null? node)274 (%skip-insert! result (skipnode-item node))275 (loop (skipnode-next node 0))))276 result))277 436 278 437 (define-with-contract (skip-reorder skp . orders) … … 286 445 (apply %skip-reorder skp orders)) 287 446 288 (define (%skip-reorder skp . orders)289 (let ((result (apply %make-skiplist-with-gap290 (%skip-max-links skp)291 (%skip-gap skp)292 orders)))293 (let loop ((node (skipnode-next (skip-start skp) 0)))294 (unless (null? node)295 (%skip-insert! result (skipnode-item node))296 (loop (skipnode-next node 0))))297 result))298 299 447 (define (set-in? lst1 lst2) 300 448 (let loop ((lst lst1)) … … 309 457 (procedure? proc)) 310 458 (%skip-for-each skp proc)) 311 312 (define (%skip-for-each skp proc)313 (let loop ((node (skipnode-next (skip-start skp) 0)))314 (unless (null? node)315 (proc (skipnode-item node))316 (loop (skipnode-next node 0)))))317 459 318 460 (define-with-contract (skip-filter skp ok?) … … 323 465 (range (%skiplist? result)) 324 466 (%skip-filter skp ok?)) 325 326 (define (%skip-filter skp ok?)327 (let ((result (apply %make-skiplist-with-gap328 (%skip-max-links skp)329 (%skip-gap skp)330 (%skip-orders skp))))331 (let loop ((node (skipnode-next (skip-start skp) 0)))332 (unless (null? node)333 (let ((item (skipnode-item node)))334 (if (ok? item) (%skip-insert! result item)))335 (loop (skipnode-next node 0))))336 result))337 467 338 468 (define-with-contract (skip-list skp . ks) … … 346 476 (apply %skip-list skp ks)) 347 477 348 (define (%skip-list skp . ks)349 (let ((k ;(if (null? ks) 0 (car ks))))350 (optional ks 0)))351 (let loop ((node (skipnode-next (skip-start skp) k)) (lst '()))352 (if (null? node)353 (reverse lst)354 (loop (skipnode-next node k) (cons (skipnode-item node) lst))))))355 356 478 (define-with-contract (skip-max-links skp) 357 479 "maximal number of links" … … 360 482 (%skip-max-links skp)) 361 483 362 (define (%skip-max-links skp)363 (skipnode-links (skip-start skp)))364 365 484 (define-with-contract (skip-dups? skp) 366 485 "check if duplicates are allowed" … … 368 487 (%skip-dups? skp)) 369 488 370 (define (%skip-dups? skp)371 ;; more than one initial comparison operator372 (not (null? (cdr (%skip-orders skp)))))373 374 489 (define-with-contract (skip-compare skp) 375 490 "combined numerical comparison procedure" … … 377 492 (range (procedure? result)) 378 493 (%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 cmp386 (lambda (x y)387 (if (zero? (cmp x y))388 ((loop rest) x y)389 (cmp x y))))))))390 494 391 495 (define-with-contract (skip-search! skp item) … … 396 500 (%skip-search! skp item)) 397 501 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 cope401 ; with lists which are alreade sorted402 (let down (403 (k (- (%skip-links skp) 1))404 ;(node (skip-start skp))405 (node (if (and lazy? (skip-lazy? skp item))406 cursor407 (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 (begin416 (set! (skipnode-next cursor k) node)417 (down (- k 1) node)))))))))418 419 502 (define-with-contract (skip-found? skp item) 420 503 "check, if last skip-search! was successfull" … … 422 505 (range (boolean? result)) 423 506 (%skip-found? skp item)) 424 425 (define (%skip-found? skp item)426 (let ((node (skipnode-next (skip-cursor skp) 0)))427 (and (not (null? node))428 (not (null? (skipnode-next node 0)))429 (zero? ((%skip-compare skp) item (skipnode-item (skipnode-next node 0)))))))430 431 (define (skip-lazy? skp item)432 (let ((node (skipnode-next (skip-cursor skp) 0)))433 (and (not (null? node))434 (not (keyword? (skipnode-item node)))435 (positive? ((%skip-compare skp) item (skipnode-item node))))))436 437 (define (skip-in? skp item node)438 (and (not (null? node))439 (not (keyword? (skipnode-item node)))440 (> ((%skip-compare skp) item (skipnode-item node)) 0)))441 507 442 508 (define-with-contract (skip-insert! skp . items) … … 450 516 (loop (cdr items))))) 451 517 452 (define (%skip-insert! skp item)453 (%skip-search! skp item #f)454 (unless (and (not (%skip-dups? skp)) (skip-found? skp item))455 (let ((newlinks (skip-rand skp)) (links (%skip-links skp)))456 (if (> newlinks links)457 (set! (%skip-links skp) newlinks))458 (skipnode-insert! (skip-cursor skp)459 (make-skipnode item (make-vector newlinks '())))460 (set! (%skip-count skp) (+ (%skip-count skp) 1)))))461 462 518 (define-with-contract (skip-remove! skp . items) 463 519 "remove nodes (one per found item) with items from skiplist" … … 469 525 (loop (cdr items))))) 470 526 471 (define (%skip-remove! skp item)472 (skip-search! skp item)473 (when (skip-found? skp item)474 (skipnode-remove! (skip-cursor skp) (%skip-links skp))475 (set! (%skip-count skp) (- (%skip-count skp) 1))))476 477 527 (define-with-contract (skip-remove-all! skp . items) 478 528 "remove nodes (all per found item) with items from skiplist" … … 484 534 (loop (cdr items))))) 485 535 486 (define (%skip-remove-all! skp item)487 (skip-search! skp item)488 (let loop ((found (skip-found? skp item)))489 (when found490 (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), one495 ;;; out of every gap nodes must have at least 2 links. Iterating we496 ;;; 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 randomization501 (let* (502 (gap (%skip-gap skp))503 (M (expt gap max-links))504 (choice (+ (random M) 1)) ; 0<=(random M)<M505 ) ; 1<=choice<=M506 (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 links510 (loop (+ links 1) (quotient barrier gap))))))))511 512 536 (define-with-contract (dups x y) 513 537 "trivial numerical comparison operator to allow for duplicates" -
release/4/skiplists/tags/0.6/skiplists.setup
r26761 r27161 3 3 (compile -O2 -s -d1 skiplists.scm -J) 4 4 (compile -O3 -d0 -s skiplists.import.scm) 5 (compile -O3 -d0 -s %skiplists.import.scm) 5 6 6 7 (install-extension 7 8 'skiplists 8 '("skiplists.so" " skiplists.import.so")9 '((version "0. 5")))9 '("skiplists.so" "%skiplists.import.so" "skiplists.import.so") 10 '((version "0.6"))) 10 11 11 12 -
release/4/skiplists/trunk/skiplists.scm
r26761 r27161 33 33 ; ju (at) jugilo (dot) de 34 34 ; 35 ; Last update: May 21, 201235 ; Last update: Aug 2, 2012 36 36 ; 37 37 ;Rationale … … 74 74 ;below n. 75 75 ; 76 (require 'records 'contracts)77 78 (module skiplists79 (skiplist s skiplist? make-skiplist make-skiplist-with-gap skip-compare80 81 82 83 84 76 (require-library records contracts) 77 78 (module %skiplists 79 (skiplist? make-skiplist make-skiplist-with-gap skip-compare 80 make-skiplist-from-list make-skiplist-with-gap-from-list 81 skip-search! skip-insert! skip-remove! skip-list skip-gap skip-count 82 skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups 83 skip-restructure skip-for-each skip-orders skip-reorder 84 skip-filter) 85 85 86 86 (import scheme records 87 (only contracts doclist doclist->dispatcher contract define-with-contract)88 87 (only chicken 89 88 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) 91 90 (only data-structures list-of?) 92 91 (only extras random)) 93 94 ;; initialize documentation95 (doclist '())96 92 97 93 ;;;; skipnode ADT (hidden) … … 149 145 '(orders gap links count cursor start))) 150 146 147 (define skiplist? (record-predicate skip-type)) 148 149 (define skip-maker 150 (record-constructor skip-type)) 151 152 (define skip-orders (record-accessor skip-type 'orders)) 153 154 (define skip-gap (record-accessor skip-type 'gap)) 155 156 (define skip-count 157 (getter-with-setter (record-accessor skip-type 'count) 158 (record-modifier skip-type 'count))) 159 160 (define skip-links 161 (getter-with-setter (record-accessor skip-type 'links) 162 (record-modifier skip-type 'links))) 163 164 (define (skip-cursor skp) 165 (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp))) 166 167 (define (skip-start skp) 168 (make-skipnode start: ((record-accessor skip-type 'start) skp))) 169 170 (define (make-skiplist max-links . orders) 171 (apply make-skiplist-with-gap max-links 2 orders)) 172 173 (define (make-skiplist-with-gap max-links gap . orders) 174 (skip-maker orders gap 1 0 175 (make-vector max-links '()) 176 (make-vector max-links '()))) 177 178 (define (make-skiplist-from-list lst max-links . orders) 179 (apply make-skiplist-with-gap-from-list lst max-links 2 orders)) 180 181 (define (make-skiplist-with-gap-from-list lst max-links gap . orders) 182 (let ((skp (apply make-skiplist-with-gap max-links gap orders))) 183 (let loop ((lst lst)) 184 (unless (null? lst) 185 (skip-insert! skp (car lst)) 186 (loop (cdr lst)))) 187 skp)) 188 189 (define (skip-restructure skp max-links gap) 190 (let ( 191 (result (apply make-skiplist-with-gap max-links gap (skip-orders skp))) 192 ) 193 (let loop ((node (skipnode-next (skip-start skp) 0))) 194 (unless (null? node) 195 (skip-insert! result (skipnode-item node)) 196 (loop (skipnode-next node 0)))) 197 result)) 198 199 (define (skip-reorder skp . orders) 200 (let ((result (apply make-skiplist-with-gap 201 (skip-max-links skp) 202 (skip-gap skp) 203 orders))) 204 (let loop ((node (skipnode-next (skip-start skp) 0))) 205 (unless (null? node) 206 (skip-insert! result (skipnode-item node)) 207 (loop (skipnode-next node 0)))) 208 result)) 209 210 (define (skip-for-each skp proc) 211 (let loop ((node (skipnode-next (skip-start skp) 0))) 212 (unless (null? node) 213 (proc (skipnode-item node)) 214 (loop (skipnode-next node 0))))) 215 216 (define (skip-filter skp ok?) 217 (let ((result (apply make-skiplist-with-gap 218 (skip-max-links skp) 219 (skip-gap skp) 220 (skip-orders skp)))) 221 (let loop ((node (skipnode-next (skip-start skp) 0))) 222 (unless (null? node) 223 (let ((item (skipnode-item node))) 224 (if (ok? item) (skip-insert! result item))) 225 (loop (skipnode-next node 0)))) 226 result)) 227 228 (define (skip-list skp . ks) 229 (let ((k ;(if (null? ks) 0 (car ks)))) 230 (optional ks 0))) 231 (let loop ((node (skipnode-next (skip-start skp) k)) (lst '())) 232 (if (null? node) 233 (reverse lst) 234 (loop (skipnode-next node k) (cons (skipnode-item node) lst)))))) 235 236 (define (skip-max-links skp) 237 (skipnode-links (skip-start skp))) 238 239 (define (skip-dups? skp) 240 ;; more than one initial comparison operator 241 (not (null? (cdr (skip-orders skp))))) 242 243 (define (skip-compare skp) 244 (let loop ((orders (skip-orders skp))) 245 (unless (null? orders) 246 (let ((cmp (car orders)) (rest (cdr orders))) 247 (if (null? rest) 248 cmp 249 (lambda (x y) 250 (if (zero? (cmp x y)) 251 ((loop rest) x y) 252 (cmp x y)))))))) 253 254 (define (skip-search! skp item . flags) 255 (let ((lazy? (optional flags #t)) (cursor (skip-cursor skp))) 256 ; the lazy? argument is set to #f in skip-insert! to cope 257 ; with lists which are alreade sorted 258 (let down ( 259 (k (- (skip-links skp) 1)) 260 ;(node (skip-start skp)) 261 (node (if (and lazy? (skip-lazy? skp item)) 262 cursor 263 (skip-start skp))) 264 ) 265 (unless (negative? k) 266 (let forward ((node node)) 267 (let ((next (skipnode-next node k))) 268 (if (skip-in? skp item next) 269 (forward next) 270 (begin 271 (set! (skipnode-next cursor k) node) 272 (down (- k 1) node))))))))) 273 274 (define (skip-found? skp item) 275 (let ((node (skipnode-next (skip-cursor skp) 0))) 276 (and (not (null? node)) 277 (not (null? (skipnode-next node 0))) 278 (zero? ((skip-compare skp) item (skipnode-item (skipnode-next node 0))))))) 279 280 (define (skip-lazy? skp item) 281 (let ((node (skipnode-next (skip-cursor skp) 0))) 282 (and (not (null? node)) 283 (not (keyword? (skipnode-item node))) 284 (positive? ((skip-compare skp) item (skipnode-item node)))))) 285 286 (define (skip-in? skp item node) 287 (and (not (null? node)) 288 (not (keyword? (skipnode-item node))) 289 (> ((skip-compare skp) item (skipnode-item node)) 0))) 290 291 (define (skip-insert! skp item) 292 (skip-search! skp item #f) 293 (unless (and (not (skip-dups? skp)) (skip-found? skp item)) 294 (let ((newlinks (skip-rand skp)) (links (skip-links skp))) 295 (if (> newlinks links) 296 (set! (skip-links skp) newlinks)) 297 (skipnode-insert! (skip-cursor skp) 298 (make-skipnode item (make-vector newlinks '()))) 299 (set! (skip-count skp) (+ (skip-count skp) 1))))) 300 301 (define (skip-remove! skp item) 302 (skip-search! skp item) 303 (when (skip-found? skp item) 304 (skipnode-remove! (skip-cursor skp) (skip-links skp)) 305 (set! (skip-count skp) (- (skip-count skp) 1)))) 306 307 (define (skip-remove-all! skp item) 308 (skip-search! skp item) 309 (let loop ((found (skip-found? skp item))) 310 (when found 311 (skipnode-remove! (skip-cursor skp) (skip-links skp)) 312 (set! (skip-count skp) (- (skip-count skp) 1)) 313 (loop (skip-found? skp item))))) 314 315 ;;; to skip gap nodes at a time in the 2nd level (link index 1), one 316 ;;; out of every gap nodes must have at least 2 links. Iterating we 317 ;;; want one out of every gap^i nodes to have at least i+1 links. 318 (define (skip-rand skp) 319 (let ((max-links (skip-max-links skp))) 320 (if (= max-links 1) 321 1 ; normal list, no randomization 322 (let* ( 323 (gap (skip-gap skp)) 324 (M (expt gap max-links)) 325 (choice (+ (random M) 1)) ; 0<=(random M)<M 326 ) ; 1<=choice<=M 327 (assert (exact? M) "too many links in skip-rand" max-links) 328 (let loop ((links 1) (barrier (quotient M gap))) 329 (if (>= choice barrier) 330 links 331 (loop (+ links 1) (quotient barrier gap)))))))) 332 333 (define (dups x y) 334 0) 335 336 ) ; module %skiplists 337 338 (module skiplists 339 (skiplists skiplist? make-skiplist make-skiplist-with-gap skip-compare 340 make-skiplist-from-list make-skiplist-with-gap-from-list 341 skip-search! skip-insert! skip-remove! skip-list skip-gap skip-count 342 skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups 343 skip-restructure skip-for-each skip-orders skip-reorder 344 skip-filter) 345 346 (import scheme 347 (prefix %skiplists %) 348 (only contracts doclist doclist->dispatcher contract define-with-contract) 349 (only chicken unless get-output-string open-output-string) 350 (only data-structures list-of?)) 351 352 ;; initialize documentation 353 (doclist '()) 354 355 ;;;; skiplist ADT 356 151 357 (define-with-contract (skiplist? xpr) 152 358 "type predicate" 153 359 (%skiplist? xpr)) 154 360 155 (define %skiplist? (record-predicate skip-type))156 157 (define skip-maker158 (record-constructor skip-type))159 160 361 (define-with-contract (skip-orders skp) 161 362 "list of numerical comparison operators" … … 164 365 (%skip-orders skp)) 165 366 166 (define %skip-orders (record-accessor skip-type 'orders))167 168 367 (define-with-contract (skip-gap skp) 169 368 "gap of skiplist" … … 172 371 (%skip-gap skp)) 173 372 174 (define %skip-gap (record-accessor skip-type 'gap))175 176 177 373 (define-with-contract (skip-count skp) 178 374 "number of nodes stored in skiplist" … … 181 377 (%skip-count skp)) 182 378 183 (define %skip-count184 (getter-with-setter (record-accessor skip-type 'count)185 (record-modifier skip-type 'count)))186 187 379 (define-with-contract (skip-links skp) 188 380 "maximal number of occupied links" … … 190 382 (range (integer? result) (>= (%skip-max-links skp) result 1)) 191 383 (%skip-links skp)) 192 193 (define %skip-links194 (getter-with-setter (record-accessor skip-type 'links)195 (record-modifier skip-type 'links)))196 197 (define (skip-cursor skp)198 (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp)))199 200 (define (skip-start skp)201 (make-skipnode start: ((record-accessor skip-type 'start) skp)))202 384 203 385 (define-with-contract (make-skiplist max-links . orders) … … 220 402 (apply %make-skiplist-with-gap max-links gap orders)) 221 403 222 (define (%make-skiplist-with-gap max-links gap . orders)223 (skip-maker orders gap 1 0224 (make-vector max-links '())225 (make-vector max-links '())))226 227 404 (define-with-contract (make-skiplist-from-list lst max-links . orders) 228 405 "construct a skiplist from an ordinary list" … … 249 426 (apply %make-skiplist-with-gap-from-list lst max-links gap orders)) 250 427 251 (define (%make-skiplist-with-gap-from-list lst max-links gap . orders)252 (let ((skp (apply %make-skiplist-with-gap max-links gap orders)))253 (let loop ((lst lst))254 (unless (null? lst)255 (%skip-insert! skp (car lst))256 (loop (cdr lst))))257 skp))258 259 428 (define-with-contract (skip-restructure skp max-links gap) 260 429 "restructure skiplist by changing max-links and gap" … … 265 434 (= (%skip-gap result) gap)) 266 435 (%skip-restructure skp max-links gap)) 267 268 (define (%skip-restructure skp max-links gap)269 (let (270 (result (apply %make-skiplist-with-gap max-links gap (%skip-orders skp)))271 )272 (let loop ((node (skipnode-next (skip-start skp) 0)))273 (unless (null? node)274 (%skip-insert! result (skipnode-item node))275 (loop (skipnode-next node 0))))276 result))277 436 278 437 (define-with-contract (skip-reorder skp . orders) … … 286 445 (apply %skip-reorder skp orders)) 287 446 288 (define (%skip-reorder skp . orders)289 (let ((result (apply %make-skiplist-with-gap290 (%skip-max-links skp)291 (%skip-gap skp)292 orders)))293 (let loop ((node (skipnode-next (skip-start skp) 0)))294 (unless (null? node)295 (%skip-insert! result (skipnode-item node))296 (loop (skipnode-next node 0))))297 result))298 299 447 (define (set-in? lst1 lst2) 300 448 (let loop ((lst lst1)) … … 309 457 (procedure? proc)) 310 458 (%skip-for-each skp proc)) 311 312 (define (%skip-for-each skp proc)313 (let loop ((node (skipnode-next (skip-start skp) 0)))314 (unless (null? node)315 (proc (skipnode-item node))316 (loop (skipnode-next node 0)))))317 459 318 460 (define-with-contract (skip-filter skp ok?) … … 323 465 (range (%skiplist? result)) 324 466 (%skip-filter skp ok?)) 325 326 (define (%skip-filter skp ok?)327 (let ((result (apply %make-skiplist-with-gap328 (%skip-max-links skp)329 (%skip-gap skp)330 (%skip-orders skp))))331 (let loop ((node (skipnode-next (skip-start skp) 0)))332 (unless (null? node)333 (let ((item (skipnode-item node)))334 (if (ok? item) (%skip-insert! result item)))335 (loop (skipnode-next node 0))))336 result))337 467 338 468 (define-with-contract (skip-list skp . ks) … … 346 476 (apply %skip-list skp ks)) 347 477 348 (define (%skip-list skp . ks)349 (let ((k ;(if (null? ks) 0 (car ks))))350 (optional ks 0)))351 (let loop ((node (skipnode-next (skip-start skp) k)) (lst '()))352 (if (null? node)353 (reverse lst)354 (loop (skipnode-next node k) (cons (skipnode-item node) lst))))))355 356 478 (define-with-contract (skip-max-links skp) 357 479 "maximal number of links" … … 360 482 (%skip-max-links skp)) 361 483 362 (define (%skip-max-links skp)363 (skipnode-links (skip-start skp)))364 365 484 (define-with-contract (skip-dups? skp) 366 485 "check if duplicates are allowed" … … 368 487 (%skip-dups? skp)) 369 488 370 (define (%skip-dups? skp)371 ;; more than one initial comparison operator372 (not (null? (cdr (%skip-orders skp)))))373 374 489 (define-with-contract (skip-compare skp) 375 490 "combined numerical comparison procedure" … … 377 492 (range (procedure? result)) 378 493 (%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 cmp386 (lambda (x y)387 (if (zero? (cmp x y))388 ((loop rest) x y)389 (cmp x y))))))))390 494 391 495 (define-with-contract (skip-search! skp item) … … 396 500 (%skip-search! skp item)) 397 501 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 cope401 ; with lists which are alreade sorted402 (let down (403 (k (- (%skip-links skp) 1))404 ;(node (skip-start skp))405 (node (if (and lazy? (skip-lazy? skp item))406 cursor407 (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 (begin416 (set! (skipnode-next cursor k) node)417 (down (- k 1) node)))))))))418 419 502 (define-with-contract (skip-found? skp item) 420 503 "check, if last skip-search! was successfull" … … 422 505 (range (boolean? result)) 423 506 (%skip-found? skp item)) 424 425 (define (%skip-found? skp item)426 (let ((node (skipnode-next (skip-cursor skp) 0)))427 (and (not (null? node))428 (not (null? (skipnode-next node 0)))429 (zero? ((%skip-compare skp) item (skipnode-item (skipnode-next node 0)))))))430 431 (define (skip-lazy? skp item)432 (let ((node (skipnode-next (skip-cursor skp) 0)))433 (and (not (null? node))434 (not (keyword? (skipnode-item node)))435 (positive? ((%skip-compare skp) item (skipnode-item node))))))436 437 (define (skip-in? skp item node)438 (and (not (null? node))439 (not (keyword? (skipnode-item node)))440 (> ((%skip-compare skp) item (skipnode-item node)) 0)))441 507 442 508 (define-with-contract (skip-insert! skp . items) … … 450 516 (loop (cdr items))))) 451 517 452 (define (%skip-insert! skp item)453 (%skip-search! skp item #f)454 (unless (and (not (%skip-dups? skp)) (skip-found? skp item))455 (let ((newlinks (skip-rand skp)) (links (%skip-links skp)))456 (if (> newlinks links)457 (set! (%skip-links skp) newlinks))458 (skipnode-insert! (skip-cursor skp)459 (make-skipnode item (make-vector newlinks '())))460 (set! (%skip-count skp) (+ (%skip-count skp) 1)))))461 462 518 (define-with-contract (skip-remove! skp . items) 463 519 "remove nodes (one per found item) with items from skiplist" … … 469 525 (loop (cdr items))))) 470 526 471 (define (%skip-remove! skp item)472 (skip-search! skp item)473 (when (skip-found? skp item)474 (skipnode-remove! (skip-cursor skp) (%skip-links skp))475 (set! (%skip-count skp) (- (%skip-count skp) 1))))476 477 527 (define-with-contract (skip-remove-all! skp . items) 478 528 "remove nodes (all per found item) with items from skiplist" … … 484 534 (loop (cdr items))))) 485 535 486 (define (%skip-remove-all! skp item)487 (skip-search! skp item)488 (let loop ((found (skip-found? skp item)))489 (when found490 (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), one495 ;;; out of every gap nodes must have at least 2 links. Iterating we496 ;;; 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 randomization501 (let* (502 (gap (%skip-gap skp))503 (M (expt gap max-links))504 (choice (+ (random M) 1)) ; 0<=(random M)<M505 ) ; 1<=choice<=M506 (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 links510 (loop (+ links 1) (quotient barrier gap))))))))511 512 536 (define-with-contract (dups x y) 513 537 "trivial numerical comparison operator to allow for duplicates" -
release/4/skiplists/trunk/skiplists.setup
r26761 r27161 3 3 (compile -O2 -s -d1 skiplists.scm -J) 4 4 (compile -O3 -d0 -s skiplists.import.scm) 5 (compile -O3 -d0 -s %skiplists.import.scm) 5 6 6 7 (install-extension 7 8 'skiplists 8 '("skiplists.so" " skiplists.import.so")9 '((version "0. 5")))9 '("skiplists.so" "%skiplists.import.so" "skiplists.import.so") 10 '((version "0.6"))) 10 11 11 12
Note: See TracChangeset
for help on using the changeset viewer.