unstable: added skip-list and interval-map
unstable/contract: added rename-contract macro-debugger: switched to use interval-map for arrows svn: r17278
This commit is contained in:
Ryan Culpepper
parent
002cfcc2d8
commit
961ece3ffe
|
|
@ -5,16 +5,15 @@
|
|||
scheme/gui
|
||||
drscheme/arrow
|
||||
framework/framework
|
||||
unstable/interval-map
|
||||
unstable/gui/notify)
|
||||
|
||||
(provide text:hover<%>
|
||||
text:hover-identifier<%>
|
||||
text:mouse-drawings<%>
|
||||
text:hover-drawings<%>
|
||||
text:arrows<%>
|
||||
|
||||
text:hover-mixin
|
||||
text:hover-identifier-mixin
|
||||
text:mouse-drawings-mixin
|
||||
text:hover-drawings-mixin
|
||||
text:tacking-mixin
|
||||
text:arrows-mixin)
|
||||
|
||||
|
|
@ -28,8 +27,8 @@
|
|||
|
||||
(define white (send the-color-database find-color "white"))
|
||||
|
||||
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
|
||||
(define-struct drawing (start end draw visible? tacked?) #:mutable)
|
||||
;; A Drawing is (make-drawing number number (??? -> void) (box boolean))
|
||||
(define-struct drawing (start end draw tacked?))
|
||||
|
||||
(define-struct idloc (start end id))
|
||||
|
||||
|
|
@ -68,20 +67,14 @@
|
|||
(interface (text:basic<%>)
|
||||
update-hover-position))
|
||||
|
||||
(define text:hover-identifier<%>
|
||||
(interface ()
|
||||
get-hovered-identifier
|
||||
set-hovered-identifier
|
||||
listen-hovered-identifier))
|
||||
|
||||
(define text:mouse-drawings<%>
|
||||
(define text:hover-drawings<%>
|
||||
(interface (text:basic<%>)
|
||||
add-mouse-drawing
|
||||
for-each-drawing
|
||||
add-hover-drawing
|
||||
get-position-drawings
|
||||
delete-all-drawings))
|
||||
|
||||
(define text:arrows<%>
|
||||
(interface (text:mouse-drawings<%>)
|
||||
(interface (text:hover-drawings<%>)
|
||||
add-arrow
|
||||
add-question-arrow
|
||||
add-billboard))
|
||||
|
|
@ -106,89 +99,62 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define text:hover-identifier-mixin
|
||||
(mixin (text:hover<%>) (text:hover-identifier<%>)
|
||||
(define-notify hovered-identifier (new notify-box% (value #f)))
|
||||
|
||||
(define idlocs null)
|
||||
|
||||
(define/public (add-identifier-location start end id)
|
||||
(set! idlocs (cons (make-idloc start end id) idlocs)))
|
||||
|
||||
(define/public (delete-all-identifier-locations)
|
||||
(set! idlocs null)
|
||||
(set-hovered-identifier #f))
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let search ([idlocs idlocs])
|
||||
(cond [(null? idlocs) (set-hovered-identifier #f)]
|
||||
[(and (<= (idloc-start (car idlocs)) pos)
|
||||
(< pos (idloc-end (car idlocs))))
|
||||
(set-hovered-identifier (idloc-id (car idlocs)))]
|
||||
[else (search (cdr idlocs))])))
|
||||
(super-new)))
|
||||
|
||||
(define text:mouse-drawings-mixin
|
||||
(mixin (text:hover<%>) (text:mouse-drawings<%>)
|
||||
(define text:hover-drawings-mixin
|
||||
(mixin (text:hover<%>) (text:hover-drawings<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position
|
||||
invalidate-bitmap-cache)
|
||||
|
||||
;; list of Drawings
|
||||
(field [drawings-list null])
|
||||
;; interval-map of Drawings
|
||||
(define drawings-list (make-numeric-interval-map))
|
||||
|
||||
(define/public add-mouse-drawing
|
||||
(case-lambda
|
||||
[(start end draw)
|
||||
(add-mouse-drawing start end draw (box #f))]
|
||||
[(start end draw tack-box)
|
||||
(set! drawings-list
|
||||
(cons (make-drawing start end draw #f tack-box)
|
||||
drawings-list))]))
|
||||
(field [hover-position #f])
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(define old-pos hover-position)
|
||||
(super update-hover-position pos)
|
||||
(set! hover-position pos)
|
||||
(unless (same-drawings? old-pos pos)
|
||||
(invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
|
||||
|
||||
(define/public (add-hover-drawing start end draw [tack-box (box #f)])
|
||||
(interval-map-cons*! drawings-list
|
||||
start (add1 end)
|
||||
(make-drawing start end draw tack-box)
|
||||
null))
|
||||
|
||||
(define/public (delete-all-drawings)
|
||||
(set! drawings-list null))
|
||||
|
||||
(define/public-final (for-each-drawing f)
|
||||
(for-each f drawings-list))
|
||||
(interval-map-remove! drawings-list -inf.0 +inf.0))
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
|
||||
((drawing-draw d) this dc left top right bottom dx dy))))))
|
||||
(for ([d (get-position-drawings hover-position)])
|
||||
((drawing-draw d) this dc left top right bottom dx dy))))
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let ([changed? (update-visible-drawings pos)])
|
||||
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
|
||||
(define/public (get-position-drawings pos)
|
||||
(if pos (interval-map-ref drawings-list pos null) null))
|
||||
|
||||
(define/private (update-visible-drawings pos)
|
||||
(let ([changed? #f])
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
|
||||
(unless (eqv? vis? (drawing-visible? d))
|
||||
(set-drawing-visible?! d vis?)
|
||||
(set! changed? #t)))))
|
||||
changed?))
|
||||
(define/private (same-drawings? old-pos pos)
|
||||
;; relies on order drawings added & list-of-eq?-struct equality
|
||||
(equal? (get-position-drawings old-pos)
|
||||
(get-position-drawings pos)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define text:tacking-mixin
|
||||
(mixin (text:basic<%> text:mouse-drawings<%>) ()
|
||||
(mixin (text:basic<%> text:hover-drawings<%>) ()
|
||||
(inherit get-canvas
|
||||
for-each-drawing)
|
||||
(inherit-field drawings-list)
|
||||
get-position-drawings)
|
||||
(inherit-field hover-position)
|
||||
(super-new)
|
||||
|
||||
(define tacked-table (make-hasheq))
|
||||
|
||||
(define/override (on-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((right-down)
|
||||
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
|
||||
(if (pair? (get-position-drawings hover-position))
|
||||
(send (get-canvas) popup-menu
|
||||
(make-tack/untack-menu)
|
||||
(send ev get-x)
|
||||
|
|
@ -197,6 +163,12 @@
|
|||
(else
|
||||
(super on-event ev))))
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(for ([draw (in-hash-keys tacked-table)])
|
||||
(draw this dc left top right bottom dx dy))))
|
||||
|
||||
(define/private (make-tack/untack-menu)
|
||||
(define menu (new popup-menu%))
|
||||
(new menu-item% (label "Tack")
|
||||
|
|
@ -210,20 +182,18 @@
|
|||
menu)
|
||||
|
||||
(define/private (tack)
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #t)))))
|
||||
(for ([d (get-position-drawings hover-position)])
|
||||
(hash-set! tacked-table (drawing-draw d) #t)
|
||||
(set-box! (drawing-tacked? d) #t)))
|
||||
(define/private (untack)
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #f)))))))
|
||||
(for ([d (get-position-drawings hover-position)])
|
||||
(hash-remove! tacked-table (drawing-draw d))
|
||||
(set-box! (drawing-tacked? d) #f)))))
|
||||
|
||||
(define text:arrows-mixin
|
||||
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
|
||||
(mixin (text:hover-drawings<%>) (text:arrows<%>)
|
||||
(inherit position-location
|
||||
add-mouse-drawing
|
||||
add-hover-drawing
|
||||
find-wordbreak)
|
||||
|
||||
(define/public (add-arrow from1 from2 to1 to2 color)
|
||||
|
|
@ -256,7 +226,7 @@
|
|||
(+ w mini mini)
|
||||
(+ h mini mini))
|
||||
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
|
||||
(add-mouse-drawing pos1 pos2 draw)))
|
||||
(add-hover-drawing pos1 pos2 draw)))
|
||||
|
||||
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
|
|
@ -286,8 +256,8 @@
|
|||
(send dc draw-text "?"
|
||||
(+ endx dx fw)
|
||||
(- (+ endy dy) fh)))))))])
|
||||
(add-mouse-drawing from1 from2 draw tack-box)
|
||||
(add-mouse-drawing to1 to2 draw tack-box))))
|
||||
(add-hover-drawing from1 from2 draw tack-box)
|
||||
(add-hover-drawing to1 to2 draw tack-box))))
|
||||
|
||||
(define/private (position->location p)
|
||||
(define xbox (box 0.0))
|
||||
|
|
@ -312,12 +282,44 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define text:mouse-drawings%
|
||||
(text:mouse-drawings-mixin
|
||||
(define text:hover-drawings%
|
||||
(text:hover-drawings-mixin
|
||||
(text:hover-mixin
|
||||
text:standard-style-list%)))
|
||||
|
||||
(define text:arrows%
|
||||
(text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
text:mouse-drawings%)))
|
||||
text:hover-drawings%)))
|
||||
|
||||
|
||||
#|
|
||||
(define text:hover-identifier<%>
|
||||
(interface ()
|
||||
get-hovered-identifier
|
||||
set-hovered-identifier
|
||||
listen-hovered-identifier))
|
||||
|
||||
(define text:hover-identifier-mixin
|
||||
(mixin (text:hover<%>) (text:hover-identifier<%>)
|
||||
(define-notify hovered-identifier (new notify-box% (value #f)))
|
||||
|
||||
(define idlocs null)
|
||||
|
||||
(define/public (add-identifier-location start end id)
|
||||
(set! idlocs (cons (make-idloc start end id) idlocs)))
|
||||
|
||||
(define/public (delete-all-identifier-locations)
|
||||
(set! idlocs null)
|
||||
(set-hovered-identifier #f))
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let search ([idlocs idlocs])
|
||||
(cond [(null? idlocs) (set-hovered-identifier #f)]
|
||||
[(and (<= (idloc-start (car idlocs)) pos)
|
||||
(< pos (idloc-end (car idlocs))))
|
||||
(set-hovered-identifier (idloc-id (car idlocs)))]
|
||||
[else (search (cdr idlocs))])))
|
||||
(super-new)))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -253,7 +253,7 @@
|
|||
(define browser-text%
|
||||
(class (text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
(text:mouse-drawings-mixin
|
||||
(text:hover-drawings-mixin
|
||||
(text:hover-mixin
|
||||
(text:hide-caret/selection-mixin
|
||||
(editor:standard-style-list-mixin text:basic%))))))
|
||||
|
|
|
|||
|
|
@ -51,8 +51,17 @@
|
|||
proj
|
||||
(lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
|
||||
|
||||
(define (rename-contract ctc name)
|
||||
(let ([ctc (coerce-contract 'rename-contract ctc)])
|
||||
(if (flat-contract? ctc)
|
||||
(flat-named-contract name (flat-contract-predicate ctc))
|
||||
(let* ([ctc-fo ((first-order-get ctc) ctc)]
|
||||
[proj ((proj-get ctc) ctc)])
|
||||
(make-proj-contract name proj ctc-fo)))))
|
||||
|
||||
(provide/contract
|
||||
[non-empty-string/c contract?]
|
||||
[path-element? contract?]
|
||||
[port-number? contract?]
|
||||
[if/c (-> procedure? contract? contract? contract?)])
|
||||
[if/c (-> procedure? contract? contract? contract?)]
|
||||
[rename-contract (-> contract? any/c contract?)])
|
||||
|
|
|
|||
266
collects/unstable/interval-map.ss
Normal file
266
collects/unstable/interval-map.ss
Normal file
|
|
@ -0,0 +1,266 @@
|
|||
#lang scheme/base
|
||||
;; owned by ryanc
|
||||
(require scheme/contract
|
||||
scheme/promise
|
||||
scheme/dict
|
||||
unstable/skip-list)
|
||||
|
||||
;; NOTE-1
|
||||
;; I need to be able to split intervals. So I can either have
|
||||
;; closed intervals on the integers or half-open intervals of
|
||||
;; arbitrary total orders. I'm going to do half-open intervals.
|
||||
|
||||
;; An interval-map is (make-interval-map skip-list =? <? translate)
|
||||
;; skip-list maps Start => (cons End Value)
|
||||
;; Invariant: intervals are disjoint (but the end of one interval
|
||||
;; can be the same as the start of the next, since half-open).
|
||||
|
||||
(define make-interval-map*
|
||||
(let ([make-interval-map
|
||||
(lambda (=? <? [translate #f])
|
||||
(make-interval-map (make-skip-list =? <?) =? <? translate))])
|
||||
make-interval-map))
|
||||
|
||||
(define (make-numeric-interval-map)
|
||||
(define (translate x y)
|
||||
(let ([offset (- y x)])
|
||||
(lambda (z) (+ z offset))))
|
||||
(make-interval-map* = < translate))
|
||||
|
||||
(define (interval-map-ref im key [default (interval-map-error key)])
|
||||
(let* ([s (interval-map-s im)]
|
||||
[<? (interval-map-<? im)]
|
||||
[istart (skip-list-iterate-greatest/<=? s key)])
|
||||
(cond [istart
|
||||
(let ([istartvalue (skip-list-iterate-value s istart)])
|
||||
(if (<? key (car istartvalue))
|
||||
(cdr istartvalue)
|
||||
(if (procedure? default) (default) default)))]
|
||||
[else
|
||||
(if (procedure? default) (default) default)])))
|
||||
|
||||
(define ((interval-map-error x))
|
||||
(error 'interval-map-ref "no mapping found for: ~e" x))
|
||||
|
||||
;; (POST x) =
|
||||
;; (if (start <= x < end)
|
||||
;; (updater (PRE x default))
|
||||
;; (PRE x))
|
||||
(define (interval-map-update*! im start end updater [default (error-for 'interval-map-update*!)])
|
||||
(define updated-defaultp
|
||||
(delay (updater (if (procedure? default) (default) default))))
|
||||
(let ([s (interval-map-s im)]
|
||||
[<? (interval-map-<? im)]
|
||||
[=? (interval-map-=? im)])
|
||||
(check-interval im start end 'interval-map-update*!)
|
||||
(split! s start <?)
|
||||
(split! s end <?)
|
||||
;; Interval ix needs updating iff start <= key(ix) < end
|
||||
;; (Also need to insert missing intervals)
|
||||
;; Main loop:
|
||||
(let loop ([start start] [ix (skip-list-iterate-least/>=? s start)])
|
||||
(cond [ix
|
||||
;; First do leading gap, [ start, key(ix) )
|
||||
(let ([ixstart (and ix (skip-list-iterate-key s ix))])
|
||||
(when (<? start ixstart)
|
||||
(skip-list-set! s start (cons ixstart (force updated-defaultp))))
|
||||
;; Then interval, [ ixstart, end(ix) )
|
||||
(when (<? ixstart end)
|
||||
(let ([ixvalue (skip-list-iterate-value s ix)])
|
||||
(skip-list-iterate-set-value! s ix
|
||||
(cons (car ixvalue) (updater (cdr ixvalue))))
|
||||
(loop (car ixvalue) (skip-list-iterate-next s ix)))))]
|
||||
[else
|
||||
;; Do gap, [ start, end )
|
||||
(when (<? start end)
|
||||
(skip-list-set! s start (cons end (force updated-defaultp))))]))))
|
||||
|
||||
|
||||
(define (interval-map-cons*! im start end obj [default null])
|
||||
(check-interval im start end 'interval-map-cons*!)
|
||||
(interval-map-update*! im start end (lambda (old) (cons obj old)) default))
|
||||
|
||||
(define ((error-for who))
|
||||
(error who "no mapping found"))
|
||||
|
||||
;; (POST x) = (if (start <= x < end) value (PRE x))
|
||||
(define (interval-map-set! im start end value)
|
||||
(check-interval im start end 'interval-map-set!)
|
||||
(interval-map-remove! im start end)
|
||||
(interval-map-update*! im start end values value))
|
||||
|
||||
(define (interval-map-remove! im start end)
|
||||
(let ([s (interval-map-s im)]
|
||||
[<? (interval-map-<? im)]
|
||||
[=? (interval-map-=? im)])
|
||||
(check-interval im start end 'interval-map-remove!)
|
||||
(split! s start <?)
|
||||
(split! s end <?)
|
||||
;; Interval ix needs removing iff start <= key(ix) < end
|
||||
;; FIXME: add batch remove to skip-lists
|
||||
(let loop ([ix (skip-list-iterate-least/>=? s start)])
|
||||
(when ix
|
||||
(let ([ixstart (skip-list-iterate-key s ix)])
|
||||
(when (<? ixstart end)
|
||||
;; Get next before we remove current
|
||||
(let ([next (skip-list-iterate-next s ix)])
|
||||
(skip-list-remove! s ixstart)
|
||||
(loop next))))))))
|
||||
|
||||
;; split!
|
||||
;; Ensures that if an interval contains x, it starts at x
|
||||
(define (split! s x <?)
|
||||
(let* ([ix (skip-list-iterate-greatest/<? s x)]
|
||||
[ixstart (and ix (skip-list-iterate-key s ix))])
|
||||
;; (ix = #f) or (key(ix) < x)
|
||||
(cond [(eq? ix #f)
|
||||
;; x <= all existing intervals; that is, either
|
||||
;; 1) x starts its own interval (=), or
|
||||
;; 2) x < all existing intervals (<)
|
||||
;; Either way, nothing to split.
|
||||
(void)]
|
||||
[else
|
||||
(let* ([ixvalue (skip-list-iterate-value s ix)]
|
||||
[ixend (car ixvalue)])
|
||||
(cond [(<? x ixend)
|
||||
;; Split; adjust ix to start at x, insert [ixstart, x)
|
||||
(skip-list-iterate-set-key! s ix x)
|
||||
(skip-list-set! s ixstart (cons x (cdr ixvalue)))]
|
||||
[else
|
||||
;; x not in ix
|
||||
(void)]))])))
|
||||
|
||||
(define (check-interval im start end who)
|
||||
(let ([<? (interval-map-<? im)])
|
||||
(unless (<? start end)
|
||||
(error who "bad interval: start ~e not less than end ~e" start end))))
|
||||
|
||||
;; Iteration
|
||||
|
||||
(define-struct interval-map-iter (si))
|
||||
|
||||
(define (interval-map-iterate-first im)
|
||||
(cond [(skip-list-iterate-first (interval-map-s im))
|
||||
=> make-interval-map-iter]
|
||||
[else #f]))
|
||||
|
||||
(define (interval-map-iterate-next im iter)
|
||||
(cond [(skip-list-iterate-next (interval-map-s im)
|
||||
(interval-map-iter-si iter))
|
||||
=> make-interval-map-iter]
|
||||
[else #f]))
|
||||
|
||||
(define (interval-map-iterate-key im iter)
|
||||
(let ([s (interval-map-s im)]
|
||||
[is (interval-map-iter-si iter)])
|
||||
(cons (skip-list-iterate-key s is)
|
||||
(car (skip-list-iterate-value s is)))))
|
||||
|
||||
(define (interval-map-iterate-value im iter)
|
||||
(let ([s (interval-map-s im)]
|
||||
[is (interval-map-iter-si iter)])
|
||||
(cdr (skip-list-iterate-value s is))))
|
||||
|
||||
;; Interval map
|
||||
|
||||
(define-struct interval-map (s =? <? translate)
|
||||
#:property prop:dict
|
||||
(vector interval-map-ref
|
||||
#f ;; set!
|
||||
#f ;; set
|
||||
#f ;; remove!
|
||||
#f ;; remove
|
||||
(lambda (im) (error 'interval-map-count "not supported"))
|
||||
interval-map-iterate-first
|
||||
interval-map-iterate-next
|
||||
interval-map-iterate-key
|
||||
interval-map-iterate-value))
|
||||
|
||||
(define (interval-map-with-translate? x)
|
||||
(and (interval-map? x)
|
||||
(procedure? (interval-map-translate x))))
|
||||
|
||||
(define (interval-map-contract! im from to)
|
||||
(let ([<? (interval-map-<? im)])
|
||||
(unless (<? from to)
|
||||
(error 'interval-map-contract!
|
||||
"start ~e not less than end ~e" from to)))
|
||||
(interval-map-remove! im from to)
|
||||
(let* ([s (interval-map-s im)]
|
||||
[translate ((interval-map-translate im) to from)])
|
||||
(apply-offset! s translate to)))
|
||||
|
||||
(define (interval-map-expand! im from to)
|
||||
(let ([<? (interval-map-<? im)])
|
||||
(unless (<? from to)
|
||||
(error 'interval-map-expand!
|
||||
"start ~e not less than end ~e" from to))
|
||||
(let* ([s (interval-map-s im)]
|
||||
[translate ((interval-map-translate im) from to)])
|
||||
(split! s from <?)
|
||||
(apply-offset! s translate from))))
|
||||
|
||||
(define (apply-offset! s translate to)
|
||||
(let loop ([ix (skip-list-iterate-least/>=? s to)])
|
||||
(when ix
|
||||
(let* ([ixkey (skip-list-iterate-key s ix)]
|
||||
[ixvalue (skip-list-iterate-value s ix)])
|
||||
(skip-list-iterate-set-key! s ix (translate ixkey))
|
||||
(skip-list-iterate-set-value! s ix
|
||||
(cons (translate (car ixvalue)) (cdr ixvalue))))
|
||||
(loop (skip-list-iterate-next s ix)))))
|
||||
|
||||
(provide/contract
|
||||
[rename make-interval-map* make-interval-map
|
||||
(-> procedure? procedure? interval-map?)]
|
||||
[make-numeric-interval-map
|
||||
(-> interval-map-with-translate?)]
|
||||
[interval-map?
|
||||
(-> any/c any)]
|
||||
[interval-map-with-translate?
|
||||
(-> any/c any)]
|
||||
[interval-map-ref
|
||||
(->* (interval-map? any/c) (any/c) any)]
|
||||
[interval-map-set!
|
||||
(-> interval-map? any/c any/c any/c any)]
|
||||
[interval-map-update*!
|
||||
(->* (interval-map? any/c any/c (-> any/c any/c)) (any/c) any)]
|
||||
[interval-map-cons*!
|
||||
(->* (interval-map? any/c any/c any/c) (any/c) any)]
|
||||
[interval-map-remove!
|
||||
(-> interval-map? any/c any/c any)]
|
||||
[interval-map-contract!
|
||||
(-> interval-map-with-translate? any/c any/c any)]
|
||||
[interval-map-expand!
|
||||
(-> interval-map-with-translate? any/c any/c any)]
|
||||
[interval-map-iterate-first
|
||||
(-> interval-map? (or/c interval-map-iter? #f))]
|
||||
[interval-map-iterate-next
|
||||
(-> interval-map? interval-map-iter? (or/c interval-map-iter? #f))]
|
||||
[interval-map-iterate-key
|
||||
(-> interval-map? interval-map-iter? any)]
|
||||
[interval-map-iterate-value
|
||||
(-> interval-map? interval-map-iter? any)]
|
||||
[interval-map-iter?
|
||||
(-> any/c any)])
|
||||
|
||||
#|
|
||||
;; Testing
|
||||
(define (dump im)
|
||||
(dict-map (interval-map-s im) list))
|
||||
|
||||
(define im (make-interval-map* = <))
|
||||
(interval-map-set! im 1 3 '(a))
|
||||
(interval-map-set! im 4 7 '(b))
|
||||
(dump im)
|
||||
;;(interval-map-remove! im 2 5)
|
||||
(interval-map-cons*! im 2 5 'c null)
|
||||
(dump im)
|
||||
|#
|
||||
|
||||
#|
|
||||
(define sim (make-interval-map* string=? string<?))
|
||||
(interval-map-set! sim "apple" "orange" 'fruit)
|
||||
(interval-map-set! sim "banana" "guava" 'tropical-fruit)
|
||||
(dump sim)
|
||||
|#
|
||||
|
|
@ -44,5 +44,15 @@ Note that the following contract is @bold{not} equivalent:
|
|||
@schemeblock[(or/c (-> any) any/c) (code:comment "wrong!")]
|
||||
The last contract is the same as @scheme[any/c] because
|
||||
@scheme[or/c] tries flat contracts before higher-order contracts.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(rename-contract [contract contract?]
|
||||
[name any/c])
|
||||
contract?]{
|
||||
|
||||
Produces a contract that acts like @scheme[contract] but with the name
|
||||
@scheme[name].
|
||||
|
||||
The resulting contract is a flat contract if @scheme[contract] is a
|
||||
flat contract.
|
||||
}
|
||||
|
|
|
|||
179
collects/unstable/scribblings/interval-map.scrbl
Normal file
179
collects/unstable/scribblings/interval-map.scrbl
Normal file
|
|
@ -0,0 +1,179 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/eval
|
||||
"utils.ss"
|
||||
(for-label unstable/interval-map
|
||||
scheme/contract
|
||||
scheme/dict
|
||||
scheme/base))
|
||||
|
||||
@title[#:tag "interval-map"]{Interval Maps}
|
||||
|
||||
@(define the-eval (make-base-eval))
|
||||
@(the-eval '(require unstable/interval-map))
|
||||
@(the-eval '(require scheme/dict))
|
||||
|
||||
@defmodule[unstable/interval-map]
|
||||
|
||||
@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]]
|
||||
|
||||
An interval-map is a mutable dictionary-like data structure where
|
||||
mappings are added by @emph{half-open} intervals and queried by
|
||||
discrete points. Interval-maps can be used with any total
|
||||
order. Internally, an interval-map uses a skip-list
|
||||
(@schememodname[unstable/skip-list]) of intervals for efficient query
|
||||
and update.
|
||||
|
||||
Interval-maps implement the dictionary (@schememodname[scheme/dict])
|
||||
interface to a limited extent. Only @scheme[dict-ref] and the
|
||||
iteraction-based methods (@scheme[dict-iterate-first],
|
||||
@scheme[dict-map], etc) are supported. For the iteration-based
|
||||
methods, the mapping's keys are considered the pairs of the start and
|
||||
end positions of the mapping's intervals.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define r (make-numeric-interval-map))
|
||||
(interval-map-set! r 1 5 'apple)
|
||||
(interval-map-set! r 6 10 'pear)
|
||||
(interval-map-set! r 3 6 'banana)
|
||||
(dict-map r list)
|
||||
]
|
||||
|
||||
@defproc[(make-interval-map [=? (any/c any/c . -> . any/c)]
|
||||
[<? (any/c any/c . -> . any/c)]
|
||||
[translate (or/c (any/c any/c . -> . (any/c . -> . any/c)) #f) #f])
|
||||
interval-map?]{
|
||||
|
||||
Makes a new empty interval-map. The interval-map uses @scheme[=?] and
|
||||
@scheme[<?] to order the endpoints of intervals.
|
||||
|
||||
If @scheme[translate] is a procedure, the interval-map supports
|
||||
contraction and expansion of regions of its domain via
|
||||
@scheme[interval-map-contract!] and @scheme[interval-map-expand!]. See
|
||||
also @scheme[make-numeric-interval-map].
|
||||
}
|
||||
|
||||
@defproc[(make-numeric-interval-map)
|
||||
interval-map-with-translate?]{
|
||||
|
||||
Makes a new empty interval-map suitable for representing numeric
|
||||
ranges.
|
||||
|
||||
Equivalent to
|
||||
@schemeblock[
|
||||
(make-interval-map = < (lambda (x y) (lambda (z) (+ z (- y x)))))
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(interval-map? [v any/c])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[#t] if @scheme[v] is an interval-map, @scheme[#f]
|
||||
otherwise.
|
||||
}
|
||||
|
||||
@defproc[(interval-map-with-translate? [v any/c])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[#t] if @scheme[v] is an interval-map constructed with
|
||||
support for translation of keys, @scheme[#f] otherwise.
|
||||
}
|
||||
|
||||
@defproc[(interval-map-ref [interval-map interval-map?]
|
||||
[position any/c]
|
||||
[default any/c (lambda () (error ....))])
|
||||
any/c]{
|
||||
|
||||
Return the value associated with @scheme[position] in
|
||||
@scheme[interval-map]. If no mapping is found, @scheme[default] is
|
||||
applied if it is a procedure, or returned otherwise.
|
||||
}
|
||||
|
||||
@defproc[(interval-map-set! [interval-map interval-map?]
|
||||
[start any/c]
|
||||
[end any/c]
|
||||
[value any/c])
|
||||
void?]{
|
||||
|
||||
Updates @scheme[interval-map], associating every position in
|
||||
[@scheme[start], @scheme[end]) with @scheme[value].
|
||||
|
||||
Existing interval mappings contained in [@scheme[start], @scheme[end])
|
||||
are destroyed, and partly overlapping intervals are truncated. See
|
||||
@scheme[interval-map-update*!] for an updating procedure that
|
||||
preserves distinctions within [@scheme[start], @scheme[end]).
|
||||
}
|
||||
|
||||
@defproc[(interval-map-update*! [interval-map interval-map?]
|
||||
[start any/c]
|
||||
[end any/c]
|
||||
[updater (any/c . -> . any/c)]
|
||||
[default any/c (lambda () (error ....))])
|
||||
void?]{
|
||||
|
||||
Updates @scheme[interval-map], associating every position in
|
||||
[@scheme[start], @scheme[end]) with the result of applying
|
||||
@scheme[updater] to the position's previously associated value, or to
|
||||
the default value produced by @scheme[default] if no mapping exists.
|
||||
|
||||
Unlike @scheme[interval-map-set!], @scheme[interval-map-update*!]
|
||||
preserves existing distinctions within [@scheme[start], @scheme[end]).
|
||||
}
|
||||
|
||||
@defproc[(interval-map-remove! [interval-map interval-map?]
|
||||
[start any/c]
|
||||
[end any/c])
|
||||
void?]{
|
||||
|
||||
Removes the value associated with every position in [@scheme[start],
|
||||
@scheme[end]).
|
||||
}
|
||||
|
||||
@defproc[(interval-map-expand! [interval-map interval-map-with-translate?]
|
||||
[start any/c]
|
||||
[end any/c])
|
||||
void?]{
|
||||
|
||||
Expands @scheme[interval-map]'s domain by introducing a gap
|
||||
[@scheme[start], @scheme[end]) and adjusting intervals after
|
||||
@scheme[start] using @scheme[(_translate start end)].
|
||||
|
||||
If @scheme[interval-map] was not constructed with a
|
||||
@scheme[_translate] argument, an exception is raised. If
|
||||
@scheme[start] is not less than @scheme[end], an exception is raised.
|
||||
}
|
||||
|
||||
@defproc[(interval-map-contract! [interval-map interval-map-with-translate?]
|
||||
[start any/c]
|
||||
[end any/c])
|
||||
void?]{
|
||||
|
||||
Contracts @scheme[interval-map]'s domain by removing all mappings on
|
||||
the interval [@scheme[start], @scheme[end]) and adjusting intervals
|
||||
after @scheme[end] using @scheme[(_translate end start)].
|
||||
|
||||
If @scheme[interval-map] was not constructed with a
|
||||
@scheme[_translate] argument, an exception is raised. If
|
||||
@scheme[start] is not less than @scheme[end], an exception is raised.
|
||||
}
|
||||
|
||||
@defproc[(interval-map-cons*! [interval-map interval-map?]
|
||||
[start any/c]
|
||||
[end any/c]
|
||||
[v any/c]
|
||||
[default any/c null])
|
||||
void?]{
|
||||
|
||||
Same as the following:
|
||||
@schemeblock[
|
||||
(interval-map-update*! interval-map start end
|
||||
(lambda (old) (cons v old))
|
||||
default)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(interval-map-iter? [v any/c])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[#t] if @scheme[v] represents a position in an
|
||||
interval-map, @scheme[#f] otherwise.
|
||||
}
|
||||
130
collects/unstable/scribblings/skip-list.scrbl
Normal file
130
collects/unstable/scribblings/skip-list.scrbl
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/eval
|
||||
"utils.ss"
|
||||
(for-label unstable/skip-list
|
||||
scheme/contract
|
||||
scheme/dict
|
||||
scheme/base))
|
||||
|
||||
@title[#:tag "skip-list"]{Skip Lists}
|
||||
|
||||
@(define the-eval (make-base-eval))
|
||||
@(the-eval '(require unstable/skip-list))
|
||||
@(the-eval '(require scheme/dict))
|
||||
|
||||
@defmodule[unstable/skip-list]
|
||||
|
||||
@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]]
|
||||
|
||||
Skip lists are a simple, efficient data structure for mutable
|
||||
dictionaries with totally ordered keys. They were described in the
|
||||
paper ``Skip Lists: A Probabilistic Alternative to Balanced Trees'' by
|
||||
William Pugh in Communications of the ACM, June 1990, 33(6) pp668-676.
|
||||
|
||||
A skip-list is a dictionary (@scheme[dict?] from
|
||||
@schememodname[scheme/dict]). It also supports extensions of the
|
||||
dictionary interface for iterator-based search and mutation.
|
||||
|
||||
@defproc[(make-skip-list [=? (any/c any/c . -> . any/c)]
|
||||
[<? (any/c any/c . -> . any/c)])
|
||||
skip-list?]{
|
||||
|
||||
Makes a new empty skip-list. The skip-list uses @scheme[=?] and @scheme[<?] to order keys.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define skip-list (make-skip-list = <))
|
||||
(skip-list-set! skip-list 3 'apple)
|
||||
(skip-list-set! skip-list 6 'cherry)
|
||||
(dict-map skip-list list)
|
||||
(skip-list-ref skip-list 3)
|
||||
(skip-list-remove! skip-list 6)
|
||||
(skip-list-count skip-list)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(skip-list? [v any/c])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[#t] if @scheme[v] is a skip-list, @scheme[#f]
|
||||
otherwise.
|
||||
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
@defproc[(skip-list-ref [skip-list skip-list?]
|
||||
[key any/c]
|
||||
[default any/c (lambda () (error ....))])
|
||||
any/c]
|
||||
@defproc[(skip-list-set! [skip-list skip-list?]
|
||||
[key any/c]
|
||||
[value any/c])
|
||||
void?]
|
||||
@defproc[(skip-list-remove! [skip-list skip-list?]
|
||||
[key any/c])
|
||||
void?]
|
||||
@defproc[(skip-list-count [skip-list skip-list?])
|
||||
exact-nonnegative-integer?]
|
||||
@defproc[(skip-list-iterate-first [skip-list skip-list?])
|
||||
(or/c skip-list-iter? #f)]
|
||||
@defproc[(skip-list-iterate-next [skip-list skip-list?]
|
||||
[iter skip-list-iter?])
|
||||
(or/c skip-list-iter? #f)]
|
||||
@defproc[(skip-list-iterate-key [skip-list skip-list?]
|
||||
[iter skip-list-iter?])
|
||||
any/c]
|
||||
@defproc[(skip-list-iterate-value [skip-list skip-list?]
|
||||
[iter skip-list-iter?])
|
||||
any/c]]]{
|
||||
|
||||
Implementations of @scheme[dict-ref], @scheme[dict-set!],
|
||||
@scheme[dict-remove!], @scheme[dict-count],
|
||||
@scheme[dict-iterate-first], @scheme[dict-iterate-next],
|
||||
@scheme[dict-iterate-key], and @scheme[dict-iterate-value],
|
||||
respectively.
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
@defproc[(skip-list-iterate-greatest/<? [skip-list skip-list?]
|
||||
[key any/c])
|
||||
(or/c skip-list-iter? #f)]
|
||||
@defproc[(skip-list-iterate-greatest/<=? [skip-list skip-list?]
|
||||
[key any/c])
|
||||
(or/c skip-list-iter? #f)]
|
||||
@defproc[(skip-list-iterate-least/>? [skip-list skip-list?]
|
||||
[key any/c])
|
||||
(or/c skip-list-iter? #f)]
|
||||
@defproc[(skip-list-iterate-least/>=? [skip-list skip-list?]
|
||||
[key any/c])
|
||||
(or/c skip-list-iter? #f)]]]{
|
||||
|
||||
Return the position of, respectively, the greatest key less than
|
||||
@scheme[key], the greatest key less than or equal to @scheme[key], the
|
||||
least key greater than @scheme[key], and the least key greater than or
|
||||
equal to @scheme[key].
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
@defproc[(skip-list-iterate-set-key! [skip-list skip-list?]
|
||||
[iter skip-list-iter?]
|
||||
[key any/c])
|
||||
void?]
|
||||
@defproc[(skip-list-iterate-set-value! [skip-list skip-list?]
|
||||
[iter skip-list-iter?]
|
||||
[value any/c])
|
||||
void?]]]{
|
||||
|
||||
Set the key and value, respectively, at the position @scheme[iter] in
|
||||
@scheme[skip-list].
|
||||
|
||||
@bold{Warning:} Changing a position's key to be less than its
|
||||
predecessor's key or greater than its successor's key results in an
|
||||
out-of-order skip-list, which may cause comparison-based operations to
|
||||
behave incorrectly.
|
||||
}
|
||||
|
||||
@defproc[(skip-list-iter? [v any/c])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[#t] if @scheme[v] represents a position in a
|
||||
skip-list, @scheme[#f] otherwise.
|
||||
}
|
||||
|
|
@ -88,6 +88,8 @@ Keep documentation and tests up to date.
|
|||
@include-section["sequence.scrbl"]
|
||||
@include-section["hash.scrbl"]
|
||||
@include-section["match.scrbl"]
|
||||
@include-section["skip-list.scrbl"]
|
||||
@include-section["interval-map.scrbl"]
|
||||
|
||||
@;{--------}
|
||||
|
||||
|
|
|
|||
355
collects/unstable/skip-list.ss
Normal file
355
collects/unstable/skip-list.ss
Normal file
|
|
@ -0,0 +1,355 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
scheme/dict)
|
||||
;; owned by ryanc
|
||||
|
||||
#|
|
||||
reference
|
||||
Skip Lists: A Probabilistic Alternative to Balanced Trees
|
||||
by William Pugh
|
||||
|
||||
I take the "fix the dice" approach to avoiding level jumps.
|
||||
Levels are indexed starting at 1, as in the paper.
|
||||
|#
|
||||
|
||||
#|
|
||||
(require (rename-in scheme/unsafe/ops
|
||||
[unsafe-vector-length vector-length]
|
||||
[unsafe-vector-ref vector-ref]
|
||||
[unsafe-vector-set! vector-set!]))
|
||||
|#
|
||||
|
||||
(define PROBABILITY-FACTOR 4)
|
||||
(define MAX-LEVEL 16)
|
||||
|
||||
(define DATA-SLOTS 2)
|
||||
|
||||
;; An Item is
|
||||
;; - (vector key data Item/#f Item/#f ...)
|
||||
|
||||
;; The Level of an Item is the number of next links it has (at least 1).
|
||||
;; The head is an Item with key and data #f (never examined)
|
||||
;; The end of the list is represented by #f
|
||||
|
||||
(define (item? x) (vector? x))
|
||||
(define (item-level item)
|
||||
(- (vector-length item) DATA-SLOTS))
|
||||
|
||||
(define (item-key item)
|
||||
(vector-ref item 0))
|
||||
(define (item-data item)
|
||||
(vector-ref item 1))
|
||||
(define (item-next item level)
|
||||
(vector-ref item (+ (+ level DATA-SLOTS) -1)))
|
||||
|
||||
(define (set-item-key! item key)
|
||||
(vector-set! item 0 key))
|
||||
(define (set-item-data! item data)
|
||||
(vector-set! item 1 data))
|
||||
(define (set-item-next! item level next)
|
||||
(vector-set! item (+ (+ level DATA-SLOTS) -1) next))
|
||||
|
||||
(define (resize-item item level)
|
||||
(define new-size (+ DATA-SLOTS level))
|
||||
(define new-item (make-vector new-size #f))
|
||||
(vector-copy! new-item 0 item 0 (min (vector-length item) new-size))
|
||||
new-item)
|
||||
|
||||
;; search : Item Nat Key Cmp Cmp -> Item/#f
|
||||
;; Returns item(R) s.t. key(R) =? key
|
||||
(define (search head level key =? <?)
|
||||
(let* ([closest (closest head level key <?)]
|
||||
[item (item-next closest 1)])
|
||||
(and (item? item)
|
||||
(=? key (item-key item))
|
||||
item)))
|
||||
|
||||
;; closest : Item Nat Key Cmp Cmp -> Item
|
||||
;; Returns greatest item R s.t. key(R) <? key.
|
||||
;; Pre: level(item) >= level, key <? key(item) OR item = head
|
||||
(define (closest item level key <?)
|
||||
(if (zero? level)
|
||||
item
|
||||
(closest (advance item level key <?) (sub1 level) key <?)))
|
||||
|
||||
;; advance : Item Nat Key Cmp -> Item
|
||||
;; Returns greatest item R s.t. key(R) <? key and level(R) >= level.
|
||||
;; Pre: level(item) >= level, key <? key(item) OR item = head
|
||||
(define (advance item level key <?)
|
||||
(let ([next (item-next item level)])
|
||||
(if (and next (<? (item-key next) key))
|
||||
(advance next level key <?)
|
||||
item)))
|
||||
|
||||
;; pick-random-level : Nat -> Nat
|
||||
;; Returns number in [1, max] (with exp. prob. dist.)
|
||||
(define (pick-random-level max)
|
||||
(let loop ([level 1])
|
||||
(if (and (< level max) (zero? (random PROBABILITY-FACTOR)))
|
||||
(loop (add1 level))
|
||||
level)))
|
||||
|
||||
;; update/insert : ... -> Item/#f
|
||||
;; Updates skip-list so that key |-> data
|
||||
;; Returns #f to indicate update (existing item changed);
|
||||
;; returns item to indicate insertion (context's links need updating)
|
||||
;; Pre: level(item) >= level, key <? key(item) OR item = head
|
||||
(define (update/insert item level key data =? <? max-level)
|
||||
(cond [(positive? level)
|
||||
(let* ([item (advance item level key <?)]
|
||||
[result (update/insert item (sub1 level)
|
||||
key data =? <? max-level)])
|
||||
(when (and result (>= (item-level result) level))
|
||||
(let ([link (item-next item level)])
|
||||
(set-item-next! item level result)
|
||||
(set-item-next! result level link)))
|
||||
result)]
|
||||
[else
|
||||
(let ([next (item-next item 1)])
|
||||
(cond [(and next (=? (item-key next) key))
|
||||
;; Update!
|
||||
(set-item-data! next data)
|
||||
#f]
|
||||
[else
|
||||
;; Insert!
|
||||
(let ([new-item
|
||||
(make-vector (+ DATA-SLOTS (pick-random-level max-level)) #f)])
|
||||
(set-item-key! new-item key)
|
||||
(set-item-data! new-item data)
|
||||
new-item)]))]))
|
||||
|
||||
;; delete : ... -> Item/#f
|
||||
;; Returns item to indicate deletion (context's links need updating);
|
||||
;; returns #f if not found.
|
||||
;; Pre: level(item) >= level; key <? key(item) OR item = head
|
||||
(define (delete item level key =? <?)
|
||||
(cond [(positive? level)
|
||||
(let* ([item (advance item level key <?)]
|
||||
[result (delete item (sub1 level) key =? <?)])
|
||||
(when (and result (eq? (item-next item level) result))
|
||||
(let ([link (item-next result level)])
|
||||
(set-item-next! item level link)
|
||||
(set-item-next! result level #f)))
|
||||
result)]
|
||||
[else
|
||||
(let ([next (item-next item 1)])
|
||||
(cond [(and next (=? (item-key next) key))
|
||||
;; Delete!
|
||||
next]
|
||||
[else
|
||||
;; Not found!
|
||||
#f]))]))
|
||||
|
||||
|
||||
;; Skip list
|
||||
|
||||
(define make-skip-list*
|
||||
(let ([make-skip-list
|
||||
(lambda (=? <?) (make-skip-list (vector 'head 'head #f) 0 =? <?))])
|
||||
make-skip-list))
|
||||
|
||||
(define (skip-list-ref s key [default (skip-list-error key)])
|
||||
(define head (skip-list-head s))
|
||||
(define result
|
||||
(search head (item-level head) key (skip-list-=? s) (skip-list-<? s)))
|
||||
(cond [result (item-data result)]
|
||||
[(procedure? default) (default)]
|
||||
[else default]))
|
||||
|
||||
(define ((skip-list-error x))
|
||||
(error 'skip-list-ref "no mapping found for: ~e" x))
|
||||
|
||||
(define (skip-list-set! s key data)
|
||||
(define head (skip-list-head s))
|
||||
(define =? (skip-list-=? s))
|
||||
(define <? (skip-list-<? s))
|
||||
(define max-level (max MAX-LEVEL (add1 (item-level head))))
|
||||
(define result ;; new Item or #f
|
||||
(update/insert head (item-level head) key data =? <? max-level))
|
||||
(when result
|
||||
(set-skip-list-num-entries! s (add1 (skip-list-count s)))
|
||||
(when (> (item-level result) (item-level head))
|
||||
(let ([new-head (resize-item head (item-level result))])
|
||||
(set-item-next! new-head (item-level result) result)
|
||||
(set-skip-list-head! s new-head)))))
|
||||
|
||||
(define (skip-list-remove! s key)
|
||||
(define head (skip-list-head s))
|
||||
(define =? (skip-list-=? s))
|
||||
(define <? (skip-list-<? s))
|
||||
(define deleted
|
||||
(delete head (item-level head) key =? <?))
|
||||
(when deleted
|
||||
(set-skip-list-num-entries! s (sub1 (skip-list-count s))))
|
||||
(unless (or (item? (item-next head (item-level head)))
|
||||
(= 1 (item-level head)))
|
||||
;; Trim head
|
||||
(let ([new-head (resize-item head (sub1 (item-level head)))])
|
||||
(set-skip-list-head! s new-head))))
|
||||
|
||||
;; Dict methods
|
||||
|
||||
(define (skip-list-count s) (skip-list-num-entries s))
|
||||
|
||||
(define-struct skip-list-iter (s item))
|
||||
|
||||
(define (check-iter who s iter)
|
||||
(unless (skip-list-iter? iter)
|
||||
(raise-type-error who "skip-list-iter" iter))
|
||||
(unless (eq? (skip-list-iter-s iter) s)
|
||||
(raise-mismatch-error who "skip-list-iter does not match skip-list" iter)))
|
||||
|
||||
(define (skip-list-iterate-first s)
|
||||
(let ([next (item-next (skip-list-head s) 1)])
|
||||
(and next (make-skip-list-iter s next))))
|
||||
|
||||
(define (skip-list-iterate-next s iter)
|
||||
(check-iter 'skip-list-iterate-next s iter)
|
||||
(let ([next (item-next (skip-list-iter-item iter) 1)])
|
||||
(and next (make-skip-list-iter s next))))
|
||||
|
||||
(define (skip-list-iterate-key s iter)
|
||||
(check-iter 'skip-list-iterate-key s iter)
|
||||
(item-key (skip-list-iter-item iter)))
|
||||
|
||||
(define (skip-list-iterate-value s iter)
|
||||
(check-iter 'skip-list-iterate-key s iter)
|
||||
(item-data (skip-list-iter-item iter)))
|
||||
|
||||
;; Extensions
|
||||
|
||||
;; Returns greatest/rightmost item s.t. key(item) < key
|
||||
(define (skip-list-iterate-greatest/<? s key)
|
||||
(let* ([head (skip-list-head s)]
|
||||
[<? (skip-list-<? s)]
|
||||
[item (closest head (item-level head) key <?)])
|
||||
(and (not (eq? item head)) (make-skip-list-iter s item))))
|
||||
|
||||
;; Returns greatest/rightmost item s.t. key(item) <= key
|
||||
(define (skip-list-iterate-greatest/<=? s key)
|
||||
(let* ([head (skip-list-head s)]
|
||||
[<? (skip-list-<? s)]
|
||||
[=? (skip-list-=? s)]
|
||||
[item< (closest head (item-level head) key <?)]
|
||||
[item1 (item-next item< 1)])
|
||||
(cond [(and item1 (=? (item-key item1) key))
|
||||
(make-skip-list-iter s item1)]
|
||||
[(eq? item< head)
|
||||
#f]
|
||||
[else
|
||||
(make-skip-list-iter s item<)])))
|
||||
|
||||
;; Returns least/leftmost item s.t. key(item) > key
|
||||
(define (skip-list-iterate-least/>? s key)
|
||||
(let* ([head (skip-list-head s)]
|
||||
[<? (skip-list-<? s)]
|
||||
[item< (closest head (item-level head) key <?)])
|
||||
(let loop ([item item<])
|
||||
(and item
|
||||
(if (<? key (item-key item))
|
||||
(make-skip-list-iter s item)
|
||||
(loop (item-next item 1)))))))
|
||||
|
||||
;; Returns least/leftmost item s.t. key(item) >= key
|
||||
(define (skip-list-iterate-least/>=? s key)
|
||||
(let* ([head (skip-list-head s)]
|
||||
[<? (skip-list-<? s)]
|
||||
[item (closest head (item-level head) key <?)]
|
||||
[item (item-next item 1)])
|
||||
(and item (make-skip-list-iter s item))))
|
||||
|
||||
(define (skip-list-iterate-set-key! s iter key)
|
||||
(check-iter 'skip-list-iterate-set-key! s iter)
|
||||
(set-item-key! (skip-list-iter-item iter) key))
|
||||
|
||||
(define (skip-list-iterate-set-value! s iter value)
|
||||
(check-iter 'skip-list-iterate-set-value! s iter)
|
||||
(set-item-data! (skip-list-iter-item iter) value))
|
||||
|
||||
|
||||
(define-struct skip-list ([head #:mutable] [num-entries #:mutable] =? <?)
|
||||
#:property prop:dict
|
||||
(vector skip-list-ref
|
||||
skip-list-set!
|
||||
#f ;; set
|
||||
skip-list-remove!
|
||||
#f ;; remove
|
||||
skip-list-count
|
||||
skip-list-iterate-first
|
||||
skip-list-iterate-next
|
||||
skip-list-iterate-key
|
||||
skip-list-iterate-value))
|
||||
|
||||
(provide/contract
|
||||
[rename make-skip-list* make-skip-list
|
||||
(-> procedure? procedure? skip-list?)]
|
||||
[skip-list?
|
||||
(-> any/c boolean?)]
|
||||
[skip-list-ref
|
||||
(->* (skip-list? any/c) (any/c) any)]
|
||||
[skip-list-set!
|
||||
(-> skip-list? any/c any/c void?)]
|
||||
[skip-list-remove!
|
||||
(-> skip-list? any/c void?)]
|
||||
[skip-list-count
|
||||
(-> skip-list? exact-nonnegative-integer?)]
|
||||
[skip-list-iterate-first
|
||||
(-> skip-list? (or/c skip-list-iter? #f))]
|
||||
[skip-list-iterate-next
|
||||
(-> skip-list? skip-list-iter? (or/c skip-list-iter? #f))]
|
||||
[skip-list-iterate-key
|
||||
(-> skip-list? skip-list-iter? any)]
|
||||
[skip-list-iterate-value
|
||||
(-> skip-list? skip-list-iter? any)]
|
||||
|
||||
[skip-list-iterate-greatest/<?
|
||||
(-> skip-list? any/c (or/c skip-list-iter? #f))]
|
||||
[skip-list-iterate-greatest/<=?
|
||||
(-> skip-list? any/c (or/c skip-list-iter? #f))]
|
||||
[skip-list-iterate-least/>?
|
||||
(-> skip-list? any/c (or/c skip-list-iter? #f))]
|
||||
[skip-list-iterate-least/>=?
|
||||
(-> skip-list? any/c (or/c skip-list-iter? #f))]
|
||||
[skip-list-iterate-set-key!
|
||||
(-> skip-list? skip-list-iter? any/c any)]
|
||||
[skip-list-iterate-set-value!
|
||||
(-> skip-list? skip-list-iter? any/c any)]
|
||||
|
||||
[skip-list-iter?
|
||||
(-> any/c any)])
|
||||
|
||||
#|
|
||||
;; Testing
|
||||
|
||||
(define s (make-skip-list* = <))
|
||||
s
|
||||
(dict-map s list)
|
||||
(skip-list-set! s 1 'apple)
|
||||
(skip-list-set! s 3 'pear)
|
||||
(skip-list-set! s 2 'orange)
|
||||
(dict-map s list)
|
||||
|
||||
(define h
|
||||
(time
|
||||
(for/hash ([n (in-range 1 50000)])
|
||||
(values (random 1000) n))))
|
||||
|
||||
(define s2 (make-skip-list* = <))
|
||||
(time
|
||||
(for ([n (in-range 1 50000)])
|
||||
(skip-list-set! s2 (random 1000) n)))
|
||||
|
||||
(define d (make-skip-list* = <))
|
||||
(time
|
||||
(for ([n (in-range 1 50000)])
|
||||
(dict-set! d (random 1000) n)))
|
||||
|
||||
|
||||
(define (find-a-bunch t)
|
||||
(for ([n (in-range 1 10000)])
|
||||
(dict-ref t (random 1000) #f)))
|
||||
|
||||
(display "\nlookup 10000 times\n")
|
||||
;(time (find-a-bunch h))
|
||||
(time (find-a-bunch s2))
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user