unstable: added skip-list and interval-map

unstable/contract: added rename-contract
macro-debugger: switched to use interval-map for arrows

svn: r17278

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:hover-drawings<%>
-         text:mouse-drawings<%>
          text:arrows<%>
 
          text:hover-mixin
-         text:hover-identifier-mixin
+         text:hover-drawings-mixin
-         text:mouse-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)
+;; A Drawing is (make-drawing number number (??? -> void) (box boolean))
-(define-struct drawing (start end draw visible? tacked?) #:mutable)
+(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<%>
+(define text:hover-drawings<%>
-  (interface ()
-    get-hovered-identifier
-    set-hovered-identifier
-    listen-hovered-identifier))
-
-(define text:mouse-drawings<%>
   (interface (text:basic<%>)
-    add-mouse-drawing
+    add-hover-drawing
-    for-each-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
+(define text:hover-drawings-mixin
-  (mixin (text:hover<%>) (text:hover-identifier<%>)
+  (mixin (text:hover<%>) (text:hover-drawings<%>)
-    (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<%>)
     (inherit dc-location-to-editor-location
              find-position
              invalidate-bitmap-cache)
 
-    ;; list of Drawings
+    ;; interval-map of Drawings
-    (field [drawings-list null])
+    (define drawings-list (make-numeric-interval-map))
 
-    (define/public add-mouse-drawing
+    (field [hover-position #f])
-      (case-lambda
+
-        [(start end draw)
+    (define/override (update-hover-position pos)
-         (add-mouse-drawing start end draw (box #f))]
+      (define old-pos hover-position)
-        [(start end draw tack-box)
+      (super update-hover-position pos)
-         (set! drawings-list 
+      (set! hover-position pos)
-               (cons (make-drawing start end draw #f tack-box)
+      (unless (same-drawings? old-pos pos)
-                     drawings-list))]))
+        (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))
+      (interval-map-remove! drawings-list -inf.0 +inf.0))
-
-    (define/public-final (for-each-drawing f)
-      (for-each f drawings-list))
 
     (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
+        (for ([d (get-position-drawings hover-position)])
-         (lambda (d)
+          ((drawing-draw d) this dc left top right bottom dx dy))))
-           (when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
-             ((drawing-draw d) this dc left top right bottom dx dy))))))
 
-    (define/override (update-hover-position pos)
+    (define/public (get-position-drawings pos)
-      (super update-hover-position pos)
+      (if pos (interval-map-ref drawings-list pos null) null))
-      (let ([changed? (update-visible-drawings pos)])
-        (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
 
-    (define/private (update-visible-drawings pos)
+    (define/private (same-drawings? old-pos pos)
-      (let ([changed? #f])
+      ;; relies on order drawings added & list-of-eq?-struct equality
-        (for-each-drawing
+      (equal? (get-position-drawings old-pos)
-         (lambda (d)
+              (get-position-drawings pos)))
-           (let ([vis? (<= (drawing-start d) pos (drawing-end d))])
-             (unless (eqv? vis? (drawing-visible? d))
-               (set-drawing-visible?! d vis?)
-               (set! changed? #t)))))
-        changed?))
 
     (super-new)))
 
 (define text:tacking-mixin
-  (mixin (text:basic<%> text:mouse-drawings<%>) ()
+  (mixin (text:basic<%> text:hover-drawings<%>) ()
     (inherit get-canvas
-             for-each-drawing)
+             get-position-drawings)
-    (inherit-field drawings-list)
+    (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
+      (for ([d (get-position-drawings hover-position)])
-       (lambda (d)
+        (hash-set! tacked-table (drawing-draw d) #t)
-         (when (drawing-visible? d)
+        (set-box! (drawing-tacked? d) #t)))
-           (set-box! (drawing-tacked? d) #t)))))
     (define/private (untack)
-      (for-each-drawing
+      (for ([d (get-position-drawings hover-position)])
-       (lambda (d)
+        (hash-remove! tacked-table (drawing-draw d))
-         (when (drawing-visible? d)
+        (set-box! (drawing-tacked? d) #f)))))
-           (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-hover-drawing from1 from2 draw tack-box)
-          (add-mouse-drawing to1 to2 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%
+(define text:hover-drawings%
-  (text:mouse-drawings-mixin
+  (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)))
+|#

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%))))))

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?)])

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 =? <? 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)
+|#

collects/unstable/scribblings/contract.scrbl

@@ -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.
 }

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 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.
+}

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 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.
+}

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"]
 
 @;{--------}
 

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 =? <?)
+  (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))
+|#