From 961ece3ffe0acfcac6d889b41dee85a32f55976f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 13 Dec 2009 03:06:58 +0000 Subject: [PATCH] unstable: added skip-list and interval-map unstable/contract: added rename-contract macro-debugger: switched to use interval-map for arrows svn: r17278 --- .../macro-debugger/syntax-browser/text.ss | 186 ++++----- .../macro-debugger/syntax-browser/widget.ss | 2 +- collects/unstable/contract.ss | 11 +- collects/unstable/interval-map.ss | 266 +++++++++++++ collects/unstable/scribblings/contract.scrbl | 12 +- .../unstable/scribblings/interval-map.scrbl | 179 +++++++++ collects/unstable/scribblings/skip-list.scrbl | 130 +++++++ collects/unstable/scribblings/unstable.scrbl | 2 + collects/unstable/skip-list.ss | 355 ++++++++++++++++++ 9 files changed, 1048 insertions(+), 95 deletions(-) create mode 100644 collects/unstable/interval-map.ss create mode 100644 collects/unstable/scribblings/interval-map.scrbl create mode 100644 collects/unstable/scribblings/skip-list.scrbl create mode 100644 collects/unstable/skip-list.ss diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index 335f1206a8..7de682d5e5 100644 --- a/collects/macro-debugger/syntax-browser/text.ss +++ b/collects/macro-debugger/syntax-browser/text.ss @@ -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))) +|# diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 7685f8f6a4..30af2e7b42 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -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%)))))) diff --git a/collects/unstable/contract.ss b/collects/unstable/contract.ss index f3d7d286c1..64b9cc4433 100644 --- a/collects/unstable/contract.ss +++ b/collects/unstable/contract.ss @@ -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?)]) diff --git a/collects/unstable/interval-map.ss b/collects/unstable/interval-map.ss new file mode 100644 index 0000000000..995bfa5c5a --- /dev/null +++ b/collects/unstable/interval-map.ss @@ -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 =? (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 (=? =? s start)]) + (cond [ix + ;; First do leading gap, [ start, key(ix) ) + (let ([ixstart (and ix (skip-list-iterate-key s ix))]) + (when (=? s start)]) + (when ix + (let ([ixstart (skip-list-iterate-key s ix)]) + (when ( 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 =? =? 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 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. } diff --git a/collects/unstable/scribblings/interval-map.scrbl b/collects/unstable/scribblings/interval-map.scrbl new file mode 100644 index 0000000000..96e0d8e37a --- /dev/null +++ b/collects/unstable/scribblings/interval-map.scrbl @@ -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)] + [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[ . 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. +} diff --git a/collects/unstable/scribblings/skip-list.scrbl b/collects/unstable/scribblings/skip-list.scrbl new file mode 100644 index 0000000000..57b9feeaad --- /dev/null +++ b/collects/unstable/scribblings/skip-list.scrbl @@ -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)]) + skip-list?]{ + +Makes a new empty skip-list. The skip-list uses @scheme[=?] and @scheme[? [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. +} diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index b5eff58733..89937631b4 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -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"] @;{--------} diff --git a/collects/unstable/skip-list.ss b/collects/unstable/skip-list.ss new file mode 100644 index 0000000000..99ecbca911 --- /dev/null +++ b/collects/unstable/skip-list.ss @@ -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 =? Item +;; Returns greatest item R s.t. key(R) = level, key Item +;; Returns greatest item R s.t. key(R) = level. +;; Pre: level(item) >= level, key 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 = (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 (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 key +(define (skip-list-iterate-least/>? s key) + (let* ([head (skip-list-head s)] + [= key +(define (skip-list-iterate-least/>=? s key) + (let* ([head (skip-list-head s)] + [ 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)) +|#